From a427657d76c8e3d4786475ab3a0f2d70f3168713 Mon Sep 17 00:00:00 2001 From: Azamat Mametjanov Date: Tue, 5 Dec 2017 17:45:52 -0800 Subject: [PATCH] Switch to -fp-model fast in standalone HOMME runs --- driver-mct/cime_config/buildexe | 59 + driver-mct/cime_config/buildnml | 405 ++ driver-mct/cime_config/config_archive.xml | 12 + driver-mct/cime_config/config_component.xml | 2686 +++++++++++ .../cime_config/config_component_acme.xml | 830 ++++ .../cime_config/config_component_cesm.xml | 534 +++ driver-mct/cime_config/config_compsets.xml | 110 + driver-mct/cime_config/config_pes.xml | 210 + .../cime_config/namelist_definition_drv.xml | 4021 ++++++++++++++++ .../namelist_definition_drv_flds.xml | 148 + .../namelist_definition_modelio.xml | 206 + .../cime_config/testdefs/testlist_drv.xml | 635 +++ .../testmods_dirs/drv/5steps/shell_commands | 2 + .../testmods_dirs/drv/default/shell_commands | 2 + .../testmods_dirs/drv/som/shell_commands | 2 + driver-mct/cime_config/user_nl_cpl | 19 + driver-mct/main/CMakeLists.txt | 9 + driver-mct/main/cime_comp_mod.F90 | 4128 +++++++++++++++++ driver-mct/main/cime_driver.F90 | 111 + driver-mct/main/component_mod.F90 | 911 ++++ driver-mct/main/component_type_mod.F90 | 265 ++ driver-mct/main/cplcomp_exchange_mod.F90 | 965 ++++ driver-mct/main/map_glc2lnd_mod.F90 | 400 ++ driver-mct/main/map_lnd2glc_mod.F90 | 481 ++ driver-mct/main/map_lnd2rof_irrig_mod.F90 | 287 ++ driver-mct/main/mrg_mod.F90 | 945 ++++ driver-mct/main/prep_aoflux_mod.F90 | 213 + driver-mct/main/prep_atm_mod.F90 | 790 ++++ driver-mct/main/prep_glc_mod.F90 | 1105 +++++ driver-mct/main/prep_ice_mod.F90 | 575 +++ driver-mct/main/prep_lnd_mod.F90 | 520 +++ driver-mct/main/prep_ocn_mod.F90 | 1348 ++++++ driver-mct/main/prep_rof_mod.F90 | 499 ++ driver-mct/main/prep_wav_mod.F90 | 361 ++ driver-mct/main/seq_diag_mct.F90 | 2526 ++++++++++ driver-mct/main/seq_domain_mct.F90 | 793 ++++ driver-mct/main/seq_flux_mct.F90 | 1502 ++++++ driver-mct/main/seq_frac_mct.F90 | 810 ++++ driver-mct/main/seq_hist_mod.F90 | 1477 ++++++ driver-mct/main/seq_io_mod.F90 | 2271 +++++++++ driver-mct/main/seq_map_mod.F90 | 908 ++++ driver-mct/main/seq_map_type_mod.F90 | 179 + driver-mct/main/seq_rest_mod.F90 | 534 +++ driver-mct/main/t_driver_timers_mod.F90 | 116 + driver-mct/shr/CMakeLists.txt | 9 + driver-mct/shr/glc_elevclass_mod.F90 | 423 ++ driver-mct/shr/seq_cdata_mod.F90 | 106 + driver-mct/shr/seq_comm_mct.F90 | 1319 ++++++ driver-mct/shr/seq_drydep_mod.F90 | 913 ++++ driver-mct/shr/seq_flds_mod.F90 | 3613 +++++++++++++++ driver-mct/shr/seq_infodata_mod.F90 | 2996 ++++++++++++ driver-mct/shr/seq_io_read_mod.F90 | 332 ++ driver-mct/shr/seq_timemgr_mod.F90 | 2583 +++++++++++ driver-mct/shr/shr_carma_mod.F90 | 70 + driver-mct/shr/shr_expr_parser_mod.F90 | 185 + driver-mct/shr/shr_fire_emis_mod.F90 | 296 ++ driver-mct/shr/shr_megan_mod.F90 | 310 ++ driver-mct/shr/shr_ndep_mod.F90 | 117 + driver-mct/unit_test/CMakeLists.txt | 65 + .../avect_wrapper_test/CMakeLists.txt | 4 + .../avect_wrapper_test/test_avect_wrapper.pf | 87 + .../check_fields_test/CMakeLists.txt | 4 + .../check_fields_test/test_check_fields.pf | 99 + .../glc_elevclass_test/CMakeLists.txt | 4 + .../glc_elevclass_test/test_glc_elevclass.pf | 286 ++ .../unit_test/map_glc2lnd_test/CMakeLists.txt | 8 + .../map_glc2lnd_test/test_map_glc2lnd.pf | 985 ++++ .../map_lnd2rof_irrig_test/CMakeLists.txt | 8 + .../test_map_lnd2rof_irrig.pf | 242 + .../unit_test/seq_map_test/CMakeLists.txt | 4 + .../unit_test/seq_map_test/test_seq_map.pf | 136 + driver-mct/unit_test/stubs/CMakeLists.txt | 5 + .../unit_test/stubs/seq_timemgr_mod.F90 | 19 + driver-mct/unit_test/utils/CMakeLists.txt | 8 + .../unit_test/utils/avect_wrapper_mod.F90 | 180 + .../unit_test/utils/create_mapper_mod.F90 | 176 + .../unit_test/utils/mct_wrapper_mod.F90 | 66 + driver-mct/unit_test/utils/simple_map_mod.F90 | 326 ++ 78 files changed, 50894 insertions(+) create mode 100755 driver-mct/cime_config/buildexe create mode 100755 driver-mct/cime_config/buildnml create mode 100644 driver-mct/cime_config/config_archive.xml create mode 100644 driver-mct/cime_config/config_component.xml create mode 100644 driver-mct/cime_config/config_component_acme.xml create mode 100644 driver-mct/cime_config/config_component_cesm.xml create mode 100644 driver-mct/cime_config/config_compsets.xml create mode 100644 driver-mct/cime_config/config_pes.xml create mode 100644 driver-mct/cime_config/namelist_definition_drv.xml create mode 100644 driver-mct/cime_config/namelist_definition_drv_flds.xml create mode 100644 driver-mct/cime_config/namelist_definition_modelio.xml create mode 100644 driver-mct/cime_config/testdefs/testlist_drv.xml create mode 100644 driver-mct/cime_config/testdefs/testmods_dirs/drv/5steps/shell_commands create mode 100755 driver-mct/cime_config/testdefs/testmods_dirs/drv/default/shell_commands create mode 100644 driver-mct/cime_config/testdefs/testmods_dirs/drv/som/shell_commands create mode 100644 driver-mct/cime_config/user_nl_cpl create mode 100644 driver-mct/main/CMakeLists.txt create mode 100644 driver-mct/main/cime_comp_mod.F90 create mode 100644 driver-mct/main/cime_driver.F90 create mode 100644 driver-mct/main/component_mod.F90 create mode 100644 driver-mct/main/component_type_mod.F90 create mode 100644 driver-mct/main/cplcomp_exchange_mod.F90 create mode 100644 driver-mct/main/map_glc2lnd_mod.F90 create mode 100644 driver-mct/main/map_lnd2glc_mod.F90 create mode 100644 driver-mct/main/map_lnd2rof_irrig_mod.F90 create mode 100644 driver-mct/main/mrg_mod.F90 create mode 100644 driver-mct/main/prep_aoflux_mod.F90 create mode 100644 driver-mct/main/prep_atm_mod.F90 create mode 100644 driver-mct/main/prep_glc_mod.F90 create mode 100644 driver-mct/main/prep_ice_mod.F90 create mode 100644 driver-mct/main/prep_lnd_mod.F90 create mode 100644 driver-mct/main/prep_ocn_mod.F90 create mode 100644 driver-mct/main/prep_rof_mod.F90 create mode 100644 driver-mct/main/prep_wav_mod.F90 create mode 100644 driver-mct/main/seq_diag_mct.F90 create mode 100644 driver-mct/main/seq_domain_mct.F90 create mode 100644 driver-mct/main/seq_flux_mct.F90 create mode 100644 driver-mct/main/seq_frac_mct.F90 create mode 100644 driver-mct/main/seq_hist_mod.F90 create mode 100644 driver-mct/main/seq_io_mod.F90 create mode 100644 driver-mct/main/seq_map_mod.F90 create mode 100644 driver-mct/main/seq_map_type_mod.F90 create mode 100644 driver-mct/main/seq_rest_mod.F90 create mode 100644 driver-mct/main/t_driver_timers_mod.F90 create mode 100644 driver-mct/shr/CMakeLists.txt create mode 100644 driver-mct/shr/glc_elevclass_mod.F90 create mode 100644 driver-mct/shr/seq_cdata_mod.F90 create mode 100644 driver-mct/shr/seq_comm_mct.F90 create mode 100644 driver-mct/shr/seq_drydep_mod.F90 create mode 100644 driver-mct/shr/seq_flds_mod.F90 create mode 100644 driver-mct/shr/seq_infodata_mod.F90 create mode 100644 driver-mct/shr/seq_io_read_mod.F90 create mode 100644 driver-mct/shr/seq_timemgr_mod.F90 create mode 100644 driver-mct/shr/shr_carma_mod.F90 create mode 100644 driver-mct/shr/shr_expr_parser_mod.F90 create mode 100644 driver-mct/shr/shr_fire_emis_mod.F90 create mode 100644 driver-mct/shr/shr_megan_mod.F90 create mode 100644 driver-mct/shr/shr_ndep_mod.F90 create mode 100644 driver-mct/unit_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/avect_wrapper_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/avect_wrapper_test/test_avect_wrapper.pf create mode 100644 driver-mct/unit_test/check_fields_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/check_fields_test/test_check_fields.pf create mode 100644 driver-mct/unit_test/glc_elevclass_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/glc_elevclass_test/test_glc_elevclass.pf create mode 100644 driver-mct/unit_test/map_glc2lnd_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/map_glc2lnd_test/test_map_glc2lnd.pf create mode 100644 driver-mct/unit_test/map_lnd2rof_irrig_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/map_lnd2rof_irrig_test/test_map_lnd2rof_irrig.pf create mode 100644 driver-mct/unit_test/seq_map_test/CMakeLists.txt create mode 100644 driver-mct/unit_test/seq_map_test/test_seq_map.pf create mode 100644 driver-mct/unit_test/stubs/CMakeLists.txt create mode 100644 driver-mct/unit_test/stubs/seq_timemgr_mod.F90 create mode 100644 driver-mct/unit_test/utils/CMakeLists.txt create mode 100644 driver-mct/unit_test/utils/avect_wrapper_mod.F90 create mode 100644 driver-mct/unit_test/utils/create_mapper_mod.F90 create mode 100644 driver-mct/unit_test/utils/mct_wrapper_mod.F90 create mode 100644 driver-mct/unit_test/utils/simple_map_mod.F90 diff --git a/driver-mct/cime_config/buildexe b/driver-mct/cime_config/buildexe new file mode 100755 index 000000000000..627330611a92 --- /dev/null +++ b/driver-mct/cime_config/buildexe @@ -0,0 +1,59 @@ +#!/usr/bin/env python + +""" +build model executable +""" + +import sys, os + +_CIMEROOT = os.path.join(os.path.dirname(os.path.abspath(__file__)), "..","..","..","..") +sys.path.append(os.path.join(_CIMEROOT, "scripts", "Tools")) + +from standard_script_setup import * +from CIME.buildlib import parse_input +from CIME.case import Case +from CIME.utils import expect, run_cmd + +logger = logging.getLogger(__name__) + +############################################################################### +def _main_func(): +############################################################################### + + caseroot, libroot, _ = parse_input(sys.argv) + + logger.info("Building a single executable version of target coupled model") + + with Case(caseroot) as case: + casetools = case.get_value("CASETOOLS") + cimeroot = case.get_value("CIMEROOT") + exeroot = case.get_value("EXEROOT") + gmake = case.get_value("GMAKE") + gmake_j = case.get_value("GMAKE_J") + model = case.get_value("MODEL") + num_esp = case.get_value("NUM_COMP_INST_ESP") + os.environ["PIO_VERSION"] = str(case.get_value("PIO_VERSION")) + + expect((num_esp is None) or (int(num_esp) == 1), "ESP component restricted to one instance") + + + with open('Filepath', 'w') as out: + out.write(os.path.join(caseroot, "SourceMods", "src.drv") + "\n") + out.write(os.path.join(cimeroot, "src", "drivers", "mct", "main") + "\n") + + # build model executable + + makefile = os.path.join(casetools, "Makefile") + exename = os.path.join(exeroot, model + ".exe") + + cmd = "%s exec_se -j %d EXEC_SE=%s MODEL=%s LIBROOT=%s -f %s "\ + % (gmake, gmake_j, exename, "driver", libroot, makefile) + + rc, out, err = run_cmd(cmd) + expect(rc==0,"Command %s failed rc=%d\nout=%s\nerr=%s"%(cmd,rc,out,err)) + logger.info(out) + +############################################################################### + +if __name__ == "__main__": + _main_func() diff --git a/driver-mct/cime_config/buildnml b/driver-mct/cime_config/buildnml new file mode 100755 index 000000000000..1b2c785a2714 --- /dev/null +++ b/driver-mct/cime_config/buildnml @@ -0,0 +1,405 @@ +#!/usr/bin/env python +"""Namelist creator for CIME's driver. +""" +# Typically ignore this. +# pylint: disable=invalid-name + +# Disable these because this is our standard setup +# pylint: disable=wildcard-import,unused-wildcard-import,wrong-import-position + +import os, shutil, sys, glob, itertools, re + +_CIMEROOT = os.path.join(os.path.dirname(os.path.abspath(__file__)), "..","..","..","..") +sys.path.append(os.path.join(_CIMEROOT, "scripts", "Tools")) + +from standard_script_setup import * +from CIME.case import Case +from CIME.nmlgen import NamelistGenerator +from CIME.utils import expect +from CIME.utils import get_model, get_time_in_seconds, get_timestamp +from CIME.buildnml import create_namelist_infile, parse_input +from CIME.XML.files import Files +from CIME.XML.grids import Grids + +logger = logging.getLogger(__name__) + +############################################################################### +def _create_drv_namelists(case, infile, confdir, nmlgen, files): +############################################################################### + + #-------------------------------- + # Set up config dictionary + #-------------------------------- + config = {} + config['cime_model'] = get_model() + config['BGC_MODE'] = case.get_value("CCSM_BGC") + config['CPL_I2O_PER_CAT'] = case.get_value('CPL_I2O_PER_CAT') + config['COMP_RUN_BARRIERS'] = case.get_value('COMP_RUN_BARRIERS') + config['DRV_THREADING'] = case.get_value('DRV_THREADING') + config['CPL_ALBAV'] = case.get_value('CPL_ALBAV') + config['CPL_EPBAL'] = case.get_value('CPL_EPBAL') + config['FLDS_WISO'] = case.get_value('FLDS_WISO') + config['BUDGETS'] = case.get_value('BUDGETS') + config['MACH'] = case.get_value('MACH') + config['MPILIB'] = case.get_value('MPILIB') + config['MULTI_DRIVER'] = '.true.' if case.get_value('MULTI_DRIVER') else '.false.' + config['OS'] = case.get_value('OS') + config['glc_nec'] = 0 if case.get_value('GLC_NEC') == 0 else case.get_value('GLC_NEC') + config['single_column'] = 'true' if case.get_value('PTS_MODE') else 'false' + config['timer_level'] = 'pos' if case.get_value('TIMER_LEVEL') >= 1 else 'neg' + config['bfbflag'] = 'on' if case.get_value('BFBFLAG') else 'off' + config['continue_run'] = '.true.' if case.get_value('CONTINUE_RUN') else '.false.' + + if case.get_value('RUN_TYPE') == 'startup': + config['run_type'] = 'startup' + elif case.get_value('RUN_TYPE') == 'hybrid': + config['run_type'] = 'startup' + elif case.get_value('RUN_TYPE') == 'branch': + config['run_type'] = 'branch' + + #---------------------------------------------------- + # Initialize namelist defaults + #---------------------------------------------------- + nmlgen.init_defaults(infile, config) + + #-------------------------------- + # Overwrite: set brnch_retain_casename + #-------------------------------- + start_type = nmlgen.get_value('start_type') + if start_type != 'startup': + if case.get_value('CASE') == case.get_value('RUN_REFCASE'): + nmlgen.set_value('brnch_retain_casename' , value='.true.') + + #-------------------------------- + # Overwrite: set component coupling frequencies + #-------------------------------- + ncpl_base_period = case.get_value('NCPL_BASE_PERIOD') + if ncpl_base_period == 'hour': + basedt = 3600 + elif ncpl_base_period == 'day': + basedt = 3600 * 24 + elif ncpl_base_period == 'year': + if case.get_value('CALENDAR') == 'NO_LEAP': + basedt = 3600 * 24 * 365 + else: + expect(False, "Invalid CALENDAR for NCPL_BASE_PERIOD {} ".format(ncpl_base_period)) + elif ncpl_base_period == 'decade': + if case.get_value('CALENDAR') == 'NO_LEAP': + basedt = 3600 * 24 * 365 * 10 + else: + expect(False, "invalid NCPL_BASE_PERIOD NCPL_BASE_PERIOD {} ".format(ncpl_base_period)) + else: + expect(False, "invalid NCPL_BASE_PERIOD NCPL_BASE_PERIOD {} ".format(ncpl_base_period)) + + if basedt < 0: + expect(False, "basedt invalid overflow for NCPL_BASE_PERIOD {} ".format(ncpl_base_period)) + + comps = case.get_values("COMP_CLASSES") + mindt = basedt + for comp in comps: + ncpl = case.get_value(comp.upper() + '_NCPL') + if ncpl is not None: + cpl_dt = int(basedt / int(ncpl)) + totaldt = cpl_dt * int(ncpl) + if totaldt != basedt: + expect(False, " {} ncpl doesn't divide base dt evenly".format(comp)) + nmlgen.add_default(comp.lower() + '_cpl_dt', value=cpl_dt) + mindt = min(mindt, cpl_dt) + + #-------------------------------- + # Overwrite: set start_ymd + #-------------------------------- + run_startdate = "".join(str(x) for x in case.get_value('RUN_STARTDATE').split('-')) + nmlgen.set_value('start_ymd', value=run_startdate) + + #-------------------------------- + # Overwrite: set tprof_option and tprof_n - if tprof_total is > 0 + #-------------------------------- + # This would be better handled inside the alarm logic in the driver routines. + # Here supporting only nday(s), nmonth(s), and nyear(s). + + stop_option = case.get_value('STOP_OPTION') + if 'nyear' in stop_option: + tprofoption = 'ndays' + tprofmult = 365 + elif 'nmonth' in stop_option: + tprofoption = 'ndays' + tprofmult = 30 + elif 'nday' in stop_option: + tprofoption = 'ndays' + tprofmult = 1 + else: + tprofmult = 1 + tprofoption = 'never' + + tprof_total = case.get_value('TPROF_TOTAL') + if ((tprof_total > 0) and (case.get_value('STOP_DATE') < 0) and ('ndays' in tprofoption)): + stop_n = case.get_value('STOP_N') + stopn = tprofmult * stop_n + tprofn = int(stopn / tprof_total) + if tprofn < 1: + tprofn = 1 + nmlgen.set_value('tprof_option', value=tprofoption) + nmlgen.set_value('tprof_n' , value=tprofn) + + # Set up the pause_component_list if pause is active + pauseo = case.get_value('PAUSE_OPTION') + if pauseo is not None and pauseo != 'never' and pauseo != 'none': + pausen = case.get_value('PAUSE_N') + # Set esp interval + if 'nstep' in pauseo: + esp_time = mindt + else: + esp_time = get_time_in_seconds(pausen, pauseo) + + nmlgen.set_value('esp_cpl_dt', value=esp_time) + # End if pause is active + + #-------------------------------- + # (1) Write output namelist file drv_in and input dataset list. + #-------------------------------- + write_drv_in_file(case, nmlgen, confdir) + + #-------------------------------- + # (2) Write out seq_map.rc file + #-------------------------------- + write_seq_maps_file(case, nmlgen, confdir) + + #-------------------------------- + # (3) Construct and write out drv_flds_in + #-------------------------------- + write_drv_flds_in_file(case, nmlgen, files) + +############################################################################### +def write_drv_in_file(case, nmlgen, confdir): +############################################################################### + data_list_path = os.path.join(case.get_case_root(), "Buildconf", "cpl.input_data_list") + if os.path.exists(data_list_path): + os.remove(data_list_path) + namelist_file = os.path.join(confdir, "drv_in") + nmlgen.write_output_file(namelist_file, data_list_path ) + +############################################################################### +def write_seq_maps_file(case, nmlgen, confdir): +############################################################################### + # first determine if there are invalid idmap settings + # if source and destination grid are different, mapping file must not be "idmap" + gridvalue = {} + ignore_component = {} + exclude_list = ["CPL","ESP"] + for comp_class in case.get_values("COMP_CLASSES"): + if comp_class not in exclude_list: + gridvalue[comp_class.lower()] = case.get_value(comp_class + "_GRID" ) + if case.get_value(comp_class + "_GRID" ) == 'null': + ignore_component[comp_class.lower()] = True + else: + ignore_component[comp_class.lower()] = False + + # Currently, hard-wire values of mapping file names to ignore + # TODO: for rof2ocn_fmapname -needs to be resolved since this is currently + # used in prep_ocn_mod.F90 if flood_present is True - this is in issue #1908. + # The following is only approriate for config_grids.xml version 2.0 or later + grid_version = Grids().get_version() + if grid_version >= 2.0: + ignore_idmaps = ["rof2ocn_fmapname", "glc2ice_rmapname", "glc2ocn_rmapname"] + group_variables = nmlgen.get_group_variables("seq_maps") + for name in group_variables: + value = group_variables[name] + if "mapname" in name: + value = re.sub('\"', '', value) + if 'idmap' == value: + component1 = name[0:3] + component2 = name[4:7] + if not ignore_component[component1] and not ignore_component[component2]: + if name in ignore_idmaps: + logger.warning(" NOTE: ignoring setting of {}=idmap in seq_maps.rc".format(name)) + else: + if "rof2ocn_" in name: + if case.get_value("COMP_OCN") == 'docn': + logger.warning(" NOTE: ignoring setting of {}=idmap in seq_maps.rc".format(name)) + else: + expect(gridvalue[component1] == gridvalue[component2], + "Need to provide valid mapping file between {} and {} in xml variable {} ".\ + format(component1, component2, name)) + + # now write out the file + seq_maps_file = os.path.join(confdir, "seq_maps.rc") + nmlgen.write_seq_maps(seq_maps_file) + +############################################################################### +def write_drv_flds_in_file(case, nmlgen, files): +############################################################################### + # In thte following, all values come simply from the infiles - no default values need to be added + # FIXME - do want to add the possibility that will use a user definition file for drv_flds_in + + caseroot = case.get_value('CASEROOT') + + nmlgen.add_default('drv_flds_in_files') + drvflds_files = nmlgen.get_default('drv_flds_in_files') + infiles = [] + for drvflds_file in drvflds_files: + infile = os.path.join(caseroot, drvflds_file) + if os.path.isfile(infile): + infiles.append(infile) + + if len(infiles) != 0: + # First read the drv_flds_in files and make sure that + # for any key there are not two conflicting values + dicts = {} + for infile in infiles: + dict_ = {} + with open(infile) as myfile: + for line in myfile: + if "=" in line and '!' not in line: + name, var = line.partition("=")[::2] + name = name.strip() + var = var.strip() + dict_[name] = var + dicts[infile] = dict_ + + for first,second in itertools.combinations(dicts.keys(),2): + compare_drv_flds_in(dicts[first], dicts[second], first, second) + + # Now create drv_flds_in + config = {} + definition_dir = os.path.dirname(files.get_value("NAMELIST_DEFINITION_FILE", attribute={"component":"drv"})) + definition_file = [os.path.join(definition_dir, "namelist_definition_drv_flds.xml")] + nmlgen = NamelistGenerator(case, definition_file, files=files) + skip_entry_loop = True + nmlgen.init_defaults(infiles, config, skip_entry_loop=skip_entry_loop) + drv_flds_in = os.path.join(caseroot, "CaseDocs", "drv_flds_in") + nmlgen.write_output_file(drv_flds_in) + +############################################################################### +def compare_drv_flds_in(first, second, infile1, infile2): +############################################################################### + sharedKeys = set(first.keys()).intersection(second.keys()) + for key in sharedKeys: + if first[key] != second[key]: + print('Key: {}, \n Value 1: {}, \n Value 2: {}'.format(key, first[key], second[key])) + expect(False, "incompatible settings in drv_flds_in from \n {} \n and \n {}".format(infile1, infile2)) + +############################################################################### +def _create_component_modelio_namelists(case, files): +############################################################################### + + # will need to create a new namelist generator + infiles = [] + definition_dir = os.path.dirname(files.get_value("NAMELIST_DEFINITION_FILE", attribute={"component":"drv"})) + definition_file = [os.path.join(definition_dir, "namelist_definition_modelio.xml")] + + confdir = os.path.join(case.get_value("CASEBUILD"), "cplconf") + lid = os.environ["LID"] if "LID" in os.environ else get_timestamp("%y%m%d-%H%M%S") + + #if we are in multi-coupler mode the number of instances of cpl will be the max + # of any NINST_* value + maxinst = 1 + if case.get_value("MULTI_DRIVER"): + maxinst = case.get_value("NINST_MAX") + + for model in case.get_values("COMP_CLASSES"): + model = model.lower() + with NamelistGenerator(case, definition_file) as nmlgen: + config = {} + config['component'] = model + entries = nmlgen.init_defaults(infiles, config, skip_entry_loop=True) + if maxinst == 1 and model != 'cpl': + inst_count = case.get_value("NINST_" + model.upper()) + else: + inst_count = maxinst + + inst_string = "" + inst_index = 1 + while inst_index <= inst_count: + # determine instance string + if inst_count > 1: + inst_string = '_{:04d}'.format(inst_index) + + # set default values + for entry in entries: + nmlgen.add_default(entry.get("id")) + + # overwrite defaults + moddiri = case.get_value('EXEROOT') + "/" + model + nmlgen.set_value('diri', moddiri) + + moddiro = case.get_value('RUNDIR') + nmlgen.set_value('diro', moddiro) + + logfile = model + inst_string + ".log." + str(lid) + nmlgen.set_value('logfile', logfile) + + # Write output file + modelio_file = model + "_modelio.nml" + inst_string + nmlgen.write_modelio_file(os.path.join(confdir, modelio_file)) + + inst_index = inst_index + 1 + +############################################################################### +def buildnml(case, caseroot, component): +############################################################################### + if component != "drv": + raise AttributeError + + confdir = os.path.join(case.get_value("CASEBUILD"), "cplconf") + if not os.path.isdir(confdir): + os.makedirs(confdir) + + # NOTE: User definition *replaces* existing definition. + # TODO: Append instead of replace? + user_xml_dir = os.path.join(caseroot, "SourceMods", "src.drv") + + expect (os.path.isdir(user_xml_dir), + "user_xml_dir {} does not exist ".format(user_xml_dir)) + + files = Files() + definition_file = [files.get_value("NAMELIST_DEFINITION_FILE", {"component": "drv"})] + + user_definition = os.path.join(user_xml_dir, "namelist_definition_drv.xml") + if os.path.isfile(user_definition): + definition_file = [user_definition] + + # Create the namelist generator object - independent of instance + nmlgen = NamelistGenerator(case, definition_file) + + # create cplconf/namelist + infile_text = "" + if case.get_value('COMP_ATM') == 'cam': + # cam is actually changing the driver namelist settings + cam_config_opts = case.get_value("CAM_CONFIG_OPTS") + if "aquaplanet" in cam_config_opts: + infile_text = "aqua_planet = .true. \n aqua_planet_sst = 1" + + user_nl_file = os.path.join(caseroot, "user_nl_cpl") + namelist_infile = os.path.join(confdir, "namelist_infile") + create_namelist_infile(case, user_nl_file, namelist_infile, infile_text) + infile = [namelist_infile] + + # create the files drv_in, drv_flds_in and seq_maps.rc + _create_drv_namelists(case, infile, confdir, nmlgen, files) + + # create the files comp_modelio.nml where comp = [atm, lnd...] + _create_component_modelio_namelists(case, files) + + # copy drv_in, drv_flds_in, seq_maps.rc and all *modio* fiels to rundir + rundir = case.get_value("RUNDIR") + + shutil.copy(os.path.join(confdir,"drv_in"), rundir) + drv_flds_in = os.path.join(caseroot, "CaseDocs", "drv_flds_in") + if os.path.isfile(drv_flds_in): + shutil.copy(drv_flds_in, rundir) + + shutil.copy(os.path.join(confdir,"seq_maps.rc"), rundir) + + for filename in glob.glob(os.path.join(confdir, "*modelio*")): + shutil.copy(filename, rundir) + +############################################################################### +def _main_func(): + caseroot = parse_input(sys.argv) + + with Case(caseroot) as case: + buildnml(case, caseroot, "drv") + +if __name__ == "__main__": + _main_func() diff --git a/driver-mct/cime_config/config_archive.xml b/driver-mct/cime_config/config_archive.xml new file mode 100644 index 000000000000..7efe6a0c511d --- /dev/null +++ b/driver-mct/cime_config/config_archive.xml @@ -0,0 +1,12 @@ + + + \.r\..* + \.h.*.nc$ + unset + + rpointer$NINST_STRING.drv + $CASE.cpl$NINST_STRING.r.$DATENAME.nc + + + + diff --git a/driver-mct/cime_config/config_component.xml b/driver-mct/cime_config/config_component.xml new file mode 100644 index 000000000000..1e784dbecdcf --- /dev/null +++ b/driver-mct/cime_config/config_component.xml @@ -0,0 +1,2686 @@ + + + + + + + + + + char + CPL,ATM,LND,ICE,OCN,ROF,GLC,WAV,ESP + env_case.xml + case_comp + List of component classes supported by this driver + + + + char + cpl + cpl + case_comp + env_case.xml + Name of coupling component + + + + + + + + + char + $CIMEROOT/config_files.xml + case_def + env_case.xml + master configuration file that specifies all relevant filenames + and directories to configure a case + + + + + + + + char + UNSET + case_def + env_case.xml + full pathname of case + + + + char + $CASEROOT/logs + run_desc + env_run.xml + Extra copies of the component log files will be saved here. + + + + char + $CASEROOT/Tools + case_der + env_case.xml + Case Tools directory location (derived variable, not in namelists + + + + char + $CASEROOT/Buildconf + case_der + env_case.xml + Buildconf directory location (derived variable not in namelist) + + + + char + $CIMEROOT/scripts + case_der + env_case.xml + Scripts root directory location (setup automatically to $CIMEROOT/scripts- DO NOT EDIT) + + + + char + UNSET + case_def + env_case.xml + full pathname of CIME source root directory + + + + char + $CIMEROOT/.. + case_def + env_case.xml + full pathname of source root directory + + + + char + $CIMEROOT/scripts/Tools + case_der + env_case.xml + Scripts root utils directory location (setup automatically to $CIMEROOT/scripts/Tools - DO NOT EDIT) + + + + + + + + char + UNSET + case_def + env_case.xml + case name + + + + char + UNSET + run_desc + env_run.xml + case description + + + + char + UNSET + case_last + env_case.xml + Component set long name (for documentation only - DO NOT EDIT) + + + + char + UNSET + build_grid + env_build.xml + Model grid - DO NOT EDIT (for experts only) + + + + char + UNSET + case_def + env_case.xml + current machine name support contact + + + + char + $ENV{USER} + case_desc + env_case.xml + case user name + + + + + + + + char + startup,hybrid,branch + startup + run_begin_stop_restart + env_run.xml + + Determines the model run initialization type. + This setting is only important for the initial run of a production run when the + CONTINUE_RUN variable is set to FALSE. After the initial run, the CONTINUE_RUN + variable is set to TRUE, and the model restarts exactly using input + files in a case, date, and bit-for-bit continuous fashion. + Default: startup. + -- In a startup run (the default), all components are initialized + using baseline states. These baseline states are set independently by + each component and can include the use of restart files, initial + files, external observed data files, or internal initialization (i.e., + a cold start). In a startup run, the coupler sends the start date to + the components at initialization. In addition, the coupler does not + need an input data file. In a startup initialization, the ocean model + does not start until the second ocean coupling (normally the second + day). + -- In a branch run, all components are initialized using a consistent + set of restart files from a previous run (determined by the + RUN_REFCASE and RUN_REFDATE variables in env_run.xml). The case name + is generally changed for a branch run, although it does not have to + be. In a branch run, setting RUN_STARTDATE is ignored because the + model components obtain the start date from their restart datasets. + Therefore, the start date cannot be changed for a branch run. This is + the same mechanism that is used for performing a restart run (where + CONTINUE_RUN is set to TRUE in the env_run.xml) Branch runs are + typically used when sensitivity or parameter studies are required, or + when settings for history file output streams need to be modified + while still maintaining bit-for-bit reproducibility. Under this + scenario, the new case is able to produce an exact bit-for-bit restart + in the same manner as a continuation run IF no source code or + component namelist inputs are modified. All models use restart files + to perform this type of run. RUN_REFCASE and RUN_REFDATE are required + for branch runs. + To set up a branch run, locate the restart tar file or restart + directory for RUN_REFCASE and RUN_REFDATE from a previous run, then + place those files in the RUNDIR directory. + --- In a hybrid run the model is initialized as a startup, BUT uses + initialization datasets FROM A PREVIOUS case. This + is somewhat analogous to a branch run with relaxed restart + constraints. A hybrid run allows users to bring together combinations + of initial/restart files from a previous case (specified by + RUN_REFCASE) at a given model output date (specified by + RUN_REFDATE). Unlike a branch run, the starting date of a hybrid run + (specified by RUN_STARTDATE) can be modified relative to the reference + case. In a hybrid run, the model does not continue in a bit-for-bit + fashion with respect to the reference case. The resulting climate, + however, should be continuous provided that no model source code or + namelists are changed in the hybrid run. In a hybrid initialization, + the ocean model does not start until the second ocean coupling + (normally the second day), and the coupler does a cold start without + a restart file. + + + + + char + ccsm4_init + run_begin_stop_restart + env_run.xml + + Reference directory containing RUN_REFCASE data - used for hybrid or branch runs + + + + + char + case.std + run_begin_stop_restart + env_run.xml + + Reference case for hybrid or branch runs + + + + + char + 0001-01-01 + run_begin_stop_restart + env_run.xml + + Reference date for hybrid or branch runs (yyyy-mm-dd) + + + + + char + 00000 + run_begin_stop_restart + env_run.xml + + Reference time of day (seconds) for hybrid or branch runs (sssss) + + + + + logical + TRUE,FALSE + FALSE + run_begin_stop_restart + env_run.xml + + Flag for automatically prestaging the refcase restart dataset. + If TRUE, then the refcase data is prestaged into the executable directory + + + + + char + 0001-01-01 + run_begin_stop_restart + env_run.xml + + Run start date (yyyy-mm-dd). Only used for startup or hybrid runs. + + + + + integer + 0 + run_begin_stop_restart + env_run.xml + + Run start time-of-day + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + ndays + run_begin_stop_restart + env_run.xml + + Sets the run length along with STOP_N and STOP_DATE + + + + + integer + 5 + run_begin_stop_restart + env_run.xml + + Provides a numerical count for $STOP_OPTION. + + + + + integer + -999 + run_begin_stop_restart + env_run.xml + + Alternative date yyyymmdd date option, sets the run length with STOP_OPTION and STOP_N + negative value implies off + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + $STOP_OPTION + run_begin_stop_restart + env_run.xml + + sets frequency of model restart writes (same options as STOP_OPTION) + + + + + integer + $STOP_N + run_begin_stop_restart + env_run.xml + + sets model restart writes with REST_OPTION and REST_DATE + + + + + char + $STOP_DATE + run_begin_stop_restart + env_run.xml + + Alternative date in yyyymmdd format + sets model restart write date with REST_OPTION and REST_N + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear + never + run_begin_stop_restart + env_run.xml + + Sets the pause frequency along with PAUSE_N + + + + + integer + 0 + run_begin_stop_restart + env_run.xml + + Provides a numerical count for $PAUSE_OPTION. + + + + + char + 1 + run_begin_stop_restart + env_run.xml + + sets periodic model barriers with BARRIER_OPTION and BARRIER_DATE for synchronization + + + + + char + -999 + run_begin_stop_restart + env_run.xml + + Alternative date in yyyymmdd format + sets periodic model barriers with BARRIER_OPTION and BARRIER_N for synchronization + + + + + logical + TRUE,FALSE + FALSE + run_begin_stop_restart + env_run.xml + + ESP component runs after driver 'pause cycle' If any component + 'pauses' (see PAUSE_OPTION, + PAUSE_N and DATA_ASSIMILATION XML variables), + the ESP component (if present) will be run to process the + component 'pause' (restart) files and set any required 'resume' + signals. If true, esp_cpl_dt and esp_cpl_offset settings are + ignored. default: false + + + + + logical + TRUE,FALSE + FALSE + run_begin_stop_restart + env_run.xml + + A setting of TRUE implies a continuation run + When you first begin a branch, hybrid or startup run, CONTINUE_RUN + must be set to FALSE. When you successfully run and get a restart + file, you will need to change CONTINUE_RUN to TRUE for the remainder + of your run. This variable determines if the run is a restart run. + Set to FALSE when initializing a startup, branch or hybrid case. + Set to TRUE when continuing a run. + + + + + integer + 0 + run_begin_stop_restart + env_run.xml + If RESUBMIT is greater than 0, then case will automatically resubmit + Enables the model to automatically resubmit a new run. To get + multiple runs, set RESUBMIT greater than 0, then RESUBMIT will be + decremented and the case will be resubmitted. The case will stop automatically + resubmitting when the RESUBMIT value reaches 0. + Long runs can easily outstrip supercomputer queue time limits. For + this reason, a case is usually run as a series of jobs, each + restarting where the previous finished. + + + + + logical + TRUE + run_begin_stop_restart + env_run.xml + This flag controls whether the RESUBMIT flag causes + CONTINUE_RUN to toggle from FALSE to TRUE. The default is + TRUE. This flag might be used in conjunction with COMP_RUN_BARRIERS for + timing tests. + + + + + logical + run_begin_stop_restart + FALSE + TRUE,FALSE + env_run.xml + Logical to determine whether CESM run has been submitted with the submit script or not + + + + char + + run_begin_stop_restart + env_run.xml + List of job ids for most recent case.submit + + + + + + + + logical + TRUE,FALSE + FALSE + run_data_archive + env_run.xml + Logical to turn on short term archiving. + If TRUE, short term archiving will be turned on. + + + + integer + 900 + run_data_archive + env_run.xml + system workload snapshot frequency (in seconds, if greater than 0; disabled otherwise) + + + + + + + + char + UNSET + config_batch + env_mach_specific.xml + The environment variables that will be loaded for this machine + + + + char + none + lc_slurm,moab,pbs,lsf,slurm,cobalt,cobalt_theta,none + config_batch + env_batch.xml + The batch system type to use for this machine. + + + + char + UNSET + config_batch + env_mach_specific.xml + The individual environment variable entry for config_machines + + + + char + UNSET + config_batch + env_mach_specific.xml + The limits tag + + + + char + UNSET + config_batch + env_mach_specific.xml + The individual limit variable + + + + + + + + char + + build_derived + env_build.xml + Perl 5 library directory + + + + char + + config_batch + env_case.xml + The mpi run command associated with the machine configured batch system + + + + char + UNSET + config_batch + env_case.xml + The module system type defined for this machine + + + + char + UNSET + config_batch + env_case.xml + The module initialization path for module system defined for this machine + + + + char + UNSET + config_batch + env_case.xml + The module command path for module system defined for this machine + + + + + + + + + char + + UNSET + build_def + env_build.xml + Output root directory for each machine. + Base directory for build and run directories. + + + + + char + + $CIME_OUTPUT_ROOT/$CASE/bld + build_def + env_build.xml + Case executable root directory. + (executable is $EXEROOT/$MODEL.exe, component libraries are in $EXEROOT/lib) + This is where the model builds its executable and by default runs the executable. + Note that EXEROOT needs to have enough disk space for the experimental configuration + requirements. As an example, a model run can produce more than a terabyte of + data during a 100-year run, so you should set EXEROOT to scratch or + tmp space and frequently back up the data to a long term archiving storage device + For a supported machine, EXEROOT is set in $CIMEROOT/machines/config_machines.xml. + For a userdefined machine, EXEROOT must explicitly be set it in env_build.xml. + + + + char + + USERDEFINED_required_macros + build_macros + env_build.xml + Operating system - DO NOT EDIT UNLESS for userdefined machine - ignored once Macros has been created. + + + + char + + + build_macros + env_build.xml + Machine compiler (must match one the supported compilers) + Set in $CIMEROOT/machines/config_machines.xml for each supported machine. + Must be explicitly set in env_build.xml for userdefined machine. + + + + char + + + build_def + env_build.xml + email address of person (or group) that supports the build and port for this machine (do not edit)> + + + + char + + USERDEFINED_required_macros + build_macros + env_build.xml + mpi library (must match one of the supported libraries) - + ignored once Macros has been created + Set in $CIMEROOT/machines/config_machines.xml for each supported machine. + Must be explicitly set in env_build.xml for userdefined machine. + + + + char + NO_LEAP,GREGORIAN + NO_LEAP + build_def + env_build.xml + calendar type + + + + char + mct,nuopc + mct + build_def + env_build.xml + use MCT component interface + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies using the ESMF library specified by ESMF_LIBDIR or ESMFMKFILE + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies turning on run and compile time debugging + Flag to turn on debugging for run time and compile time. + If TRUE, compile-time debugging flags are activated that you can use to verify + software robustness, such as bounds checking. + Important:: On IBM machines, floating point trapping is not activated for production + runs (i.e., non-DEBUG), due to performance penalties associated with turning on these flags. + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies always build model for openmp capability + If FALSE, component libraries are built with OpenMP capability only if + the NTHREADS_ setting for that component is greater than 1 in env_mach_pes.xml. + If TRUE, the component libraries are always built with OpenMP capability. + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies that at least one of the components is built threaded (DO NOT EDIT) + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies linking to the PETSc library - set + automatically by XXX_USE_PETSC options (do not edit). Flag to turn + on linking to the PETSc library. Currently this is used by + CLM. This is currently only supported for certain machines. + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies linking to the Albany library - set + automatically by XXX_USE_ALBANY options (do not edit). Flag to + turn on linking to the Albany library. Currently this is used by + MPASLI. Note that Albany is a C++ library, so setting this + variable to TRUE will involve the inclusion of C++ code in the + MPASLI executable. This is currently only supported for certain + machines. + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies linking to the MOAB library + + + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies linking to the trilinos library - set automatically by XXX_USE_TRILINOS options (do not edit) + Flag to turn on linking to the trilinos library. Currently this is + used by CISM. Note that trilinos is a C++ library, so setting this + variable to TRUE will involve the inclusion of C++ code in the model + executable. This is currently only supported for certain machines. + + + + char + + gmake + build_def + env_build.xml + GNU make command + + + + integer + + 1 + build_def + env_build.xml + Number of processors for gmake + + + + logical + TRUE,FALSE + FALSE + build_status + env_build.xml + Status output: if TRUE, models have been built successfully. (DO NOT EDIT)> + + + + char + + 0 + build_status + env_build.xml + Status: smp status of previous build, coded string. (DO NOT EDIT) + + + + char + + 0 + build_status + env_build.xml + Status: smp status of current case, coded string (DO NOT EDIT) + + + + char + + 0 + build_status + env_build.xml + Status: ninst status of previous build, coded string. (DO NOT EDIT)> + + + + char + + 0 + build_status + env_build.xml + Status: ninst status of current case, coded string (DO NOT EDIT) + + + + integer + 0,1,2 + 0 + build_status + env_build.xml + Status: of prior build. (DO NOT EDIT) + + + + char + + $EXEROOT + build_derived + env_build.xml + case build directory (set automatically to $EXEROOT, - DO NOT EDIT) + + + + char + + $EXEROOT/lib + build_derived + env_build.xml + case lib directory (set automatically to $EXEROOT/lib - DO NOT EDIT) + + + + char + + $EXEROOT/lib/include + build_derived + env_build.xml + case lib include directory (set automatically to $EXEROOT/lib/include - DO NOT EDIT) + + + + char + + $EXEROOT + build_derived + env_build.xml + Shared library root, (set automatically to $EXEROOT - DO NOT EDIT) + + + + + + + + logical + TRUE,FALSE + TRUE + run_flags + env_run.xml + logical to diagnose model timing at the end of the run + + + + logical + TRUE,FALSE + FALSE + run_cesm + env_run.xml + Enables the papi hardware counters in gptl + The papi library must be included in the build step for + this to work. + + + + char + ESMF_LOGKIND_SINGLE,ESMF_LOGKIND_MULTI,ESMF_LOGKIND_NONE + ESMF_LOGKIND_NONE + run_cesm + env_run.xml + + Determines what ESMF log files (if any) are generated when + USE_ESMF_LIB is TRUE. + ESMF_LOGKIND_SINGLE: Use a single log file, combining messages from + all of the PETs. Not supported on some platforms. + ESMF_LOGKIND_MULTI: Use multiple log files -- one per PET. + ESMF_LOGKIND_NONE: Do not issue messages to a log file. + By default, no ESMF log files are generated. + + + + + logical + TRUE,FALSE + FALSE + run_flags + env_run.xml + Turns on component barriers for component timing. + This variable is for testing and debugging only and should never + be set for a production run. + + + + + integer + 0 + mach_pes_last + env_mach_pes.xml + pes or cores used relative to MAX_MPITASKS_PER_NODE for accounting (0 means TOTALPES is valid) + + + + + + + + char + UNSET + build_grid + env_build.xml + atmosphere grid - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of atmosphere cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of atmosphere cells in j direction - DO NOT EDIT (for experts only) + + + + char + UNSET + build_grid + env_build.xml + land grid - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of land cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of land cells in j direction - DO NOT EDIT (for experts only) + + + + char + UNSET + build_grid + env_build.xml + ocn grid - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of ocn cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of ocn cells in j direction - DO NOT EDIT (for experts only) + + + + char + UNSET + build_grid + env_build.xml + ice grid (must equal ocn grid) - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of ice cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of ice cells in j direction - DO NOT EDIT (for experts only) + + + + integer + 1 + build_grid + env_build.xml + number of ice thickness categories - DO NOT EDIT (set by CICE configure) + + + + char + UNSET + build_grid + env_build.xml + river runoff (rof) grid + + + + integer + 0 + build_grid + env_build.xml + number of rof cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of rof cells in j direction - DO NOT EDIT (for experts only) + + + + char + gland20,gland10,gland5,gland5UM,gland4,mpas.gis20km,mpas.ais20km,null + gland5UM + build_grid + env_build.xml + glacier (glc) grid - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of glc cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of glc cells in j direction - DO NOT EDIT (for experts only) + + + + + char + UNSET + build_grid + env_build.xml + wave model (wav) grid + + + + integer + 0 + build_grid + env_build.xml + number of wav cells in i direction - DO NOT EDIT (for experts only) + + + + integer + 0 + build_grid + env_build.xml + number of wav cells in j direction - DO NOT EDIT (for experts only) + + + + char + UNSET + build_grid + env_build.xml + grid mask - DO NOT EDIT (for experts only) + + + + logical + TRUE,FALSE + FALSE + run_domain + env_run.xml + Operate on only a single point of the global grid - DO NOT EDIT (for experts only) + + + + real + -999.99 + run_domain + env_run.xml + Latitude to find nearest points for points mode (only used if PTS_MODE is TRUE) + + + + real + -999.99 + run_domain + env_run.xml + Longitude to find nearest points for points mode (only used if PTS_MODE is TRUE) + + + + + + + + char + UNSET + run_domain + env_run.xml + atm domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of atm domain file + + + + char + UNSET + run_domain + env_run.xml + lnd domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of lnd domain file + + + + char + UNSET + run_domain + env_run.xml + rof domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of rof domain file + + + + char + UNSET + run_domain + env_run.xml + wav domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of wav domain file + + + + char + UNSET + run_domain + env_run.xml + ice domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of ice domain file + + + + char + UNSET + run_domain + env_run.xml + ocn domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of ocn domain file + + + + char + UNSET + run_domain + env_run.xml + glc domain file + + + + char + $DIN_LOC_ROOT/share/domains + run_domain + env_run.xml + path of glc domain file + + + + + + + char + idmap + run_domain + env_run.xml + atm2ocn flux mapping file + + + + char + X,Y + X + run_domain + env_run.xml + atm2ocn flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + atm2ocn state mapping file + + + + char + X,Y + X + run_domain + env_run.xml + atm2ocn state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + atm2ocn vector mapping file + + + + char + X,Y + X + run_domain + env_run.xml + atm2ocn vector mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + atm2lnd flux mapping file + + + + char + X,Y + X + run_domain + env_run.xml + atm2lnd flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + atm2lnd state mapping file + + + + char + X,Y + X + run_domain + env_run.xml + atm2lnd state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + atm2wav state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + atm2wav state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + ocn2atm flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ocn2atm flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + ocn2atm state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ocn2atm state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + lnd2atm flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + lnd2atm flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + lnd2atm state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + lnd2atm state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + lnd2glc flux mapping file + + + + char + X,Y + X + run_domain + env_run.xml + lnd2glc flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + lnd2glc state mapping file + + + + char + X,Y + X + run_domain + env_run.xml + lnd2glc state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + lnd2rof flux mapping file + + + + char + X,Y + X + run_domain + env_run.xml + lnd2rof flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + rof2lnd flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + rof2lnd flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + rof2ocn flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + rof2ocn flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + rof2ocn runoff mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + rof2ocn runoff mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + rof2ocn runoff mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + rof2ocn runoff mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2lnd flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2lnd flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2lnd state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2lnd state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2ice runoff mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2ice runoff mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2ocn runoff mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2ocn runoff mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + ocn2wav state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ocn2wav state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + ice2wav state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ice2wav state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + wav2ocn state mapping file + + + + char + X,Y + X + run_domain + env_run.xml + wav2ocn state mapping file decomp type + + + + char + none,npfix,cart3d,cart3d_diag,cart3d_uvw,cart3d_uvw_diag + cart3d + run_domain + env_run.xml + vector mapping option + + + + char + 1.0e-02 + run_domain + env_run.xml + Error tolerance for differences in fractions in domain checking + + + + real + 9.0e-07 + run_domain + env_run.xml + Error tolerance for differences in atm/land areas in domain checking + + + + real + 1.0e-13 + run_domain + env_run.xml + Error tolerance for differences in atm/land masks in domain checking + + + + real + 1.0e-12 + run_domain + env_run.xml + Error tolerance for differences in atm/land lat/lon in domain checking + + + + real + 1.0e-01 + run_domain + env_run.xml + Error tolerance for differences in ocean/ice lon/lat in domain checking + + + + real + 1.0e-06 + run_domain + env_run.xml + Error tolerance for differences in ocean/ice lon/lat in domain checking + + + + real + 1.0e-02 + run_domain + env_run.xml + Error tolerance for differences in ocean/ice lon/lat in domain checking + + + + + + + + char + UNSET + case_def + env_case.xml + Machine name + + + + char + + case_def + env_case.xml + Machines directory location + + + + char + $CIME_OUTPUT_ROOT/$CASE/run + run_desc + env_run.xml + + The directory where the executable will be run. + By default this is set to EXEROOT/../run. + RUNDIR allows you to keep the run directory separate from the build directory + + + + + char + UNSET + run_din + env_run.xml + + A regular expression to match machine node names to ACME machine. + + + + + char + run_din + env_run.xml + + A regular expression to search for an indication that a run failure was caused by a node failure + and should therefore be re-attempted. + + + + + char + UNSET + run_din + env_run.xml + + Proxy (if any) setting for http_proxy to allow web access on this machine. + + + + + logical + FALSE + run_din + env_run.xml + + Indicates to case.submit that this is a test case. + + + + + char + UNSET + run_din + env_run.xml + + The root directory of all CIME and component input data for the selected machine. + This is usually a shared disk area. + Default values for the target machine are in the + $CIMEROOT/machines/config_machines.xml + + + + + char + UNSET + run_din + env_run.xml + CLM-specific root directory for CLM type input forcing data + This directory will only be used for I (CLM/DATM) compsets and only + for datm forcing data that is NOT checked into the svn repository + (datasets other than the Qian or single-point forcing). + This is usually a shared disk area. + Default values for the target machine are in the + $CIMEROOT/machines/config_machines.xml + + + + char + UNSET + run_dout + env_run.xml + Root directory for short term archiving. This directory must be visible to compute nodes. + + + + char + UNSET + run_mpi + env_run.xml + override the mpi run command, do not include model executable + + + + + + + + logical + TRUE,FALSE + FALSE + mach_pes + env_mach_pes.xml + Allocate some spare nodes to handle node failures. The system will pick a reasonable number + + + + integer + -999 + mach_pes + env_mach_pes.xml + Force this exact number of spare nodes to be allocated + + + + integer + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + mach_pes + env_mach_pes.xml + number of tasks for each component + + + + integer + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + mach_pes + env_mach_pes.xml + Number of tasks per instance for each component. DO NOT EDIT: Set automatically by case.setup based on NTASKS, NINST and MULTI_DRIVER + + + + integer + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + mach_pes + env_mach_pes.xml + number of threads for each task in each component + + + + integer + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + mach_pes + env_mach_pes.xml + ROOTPE (mpi task in MPI_COMM_WORLD) for each component + + + + logical + FALSE + TRUE,FALSE + mach_pes + env_mach_pes.xml + MULTI_DRIVER mode provides a separate driver/coupler component for each + ensemble member. All components must have an equal number of members. If + MULTI_DRIVER mode is False prognostic components must have the same number + of members but data or stub components may also have 1 member. + + + + integer + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + mach_pes + env_mach_pes.xml + Number of instances for each component. If MULTI_DRIVER is True + the NINST_MAX value will be used. + + + + + char + sequential,concurrent + + concurrent + concurrent + concurrent + concurrent + concurrent + concurrent + concurrent + concurrent + + mach_pes + env_mach_pes.xml + Layout of component instances for each component + + + + integer + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + mach_pes + env_mach_pes.xml + Number of instances for each component + + + + integer + 0 + mach_pes_last + env_mach_pes.xml + total number of MPI tasks (setup automatically - DO NOT EDIT) + + + + integer + 0 + mach_pes_last + env_mach_pes.xml + maximum number of tasks/ threads allowed per node + + + + integer + 0 + mach_pes_last + env_mach_pes.xml + pes or cores per node for mpitasks + + + + integer + $MAX_MPITASKS_PER_NODE + mach_pes_last + env_mach_pes.xml + pes or cores per node for accounting purposes + + + + + + + + integer + 1 + 1,2 + build_macros + env_build.xml + PIO library version + + + + char + + build_macros + env_build.xml + PIO configure options, see PIO configure utility for details + + + + logical + TRUE,FALSE + FALSE + run_pio + env_run.xml + TRUE implies perform asynchronous i/o + + + + char + p2p,coll,default + p2p + run_pio + env_run.xml + pio rearranger communication type + + + + char + 2denable,io2comp,comp2io,disable,default + 2denable + run_pio + env_run.xml + pio rearranger communication flow control direction + + + + integer + + 0 + run_pio + env_run.xml + pio rearranger communication max pending requests (comp2io) : 0 implies that CIME internally calculates the value ( = max(64, 2 * PIO_NUMTASKS) ), -1 implies no bound on max pending requests + + + + logical + TRUE,FALSE + TRUE + run_pio + env_run.xml + pio rearranger communiation options (comp2io) : TRUE implies enable handshake + + + + logical + TRUE,FALSE + FALSE + run_pio + env_run.xml + pio rearranger communiation options (comp2io) : TRUE implies enable isend + + + + integer + + 64 + run_pio + env_run.xml + pio rearranger communication max pending requests (io2comp) : -1 implies no bound on max pending requests + + + + + + logical + TRUE,FALSE + FALSE + run_pio + env_run.xml + pio rearranger communiation options (io2comp) : TRUE implies enable handshake + + + + logical + TRUE,FALSE + TRUE + run_pio + env_run.xml + pio rearranger communiation options (io2comp) : TRUE implies enable isend + + + + + integer + 0 + run_pio + env_run.xml + pio debug level + + + + integer + -1 + run_pio + env_run.xml + pio blocksize for box decompositions + + + + integer + -1 + run_pio + env_run.xml + pio buffer size limit for pnetcdf output + + + + char + netcdf,pnetcdf,netcdf4p,netcdf4c,default + run_pio + env_run.xml + pio io type + + default + default + default + default + default + default + default + default + default + + + + + char + classic,64bit_offset,64bit_data + run_pio + env_run.xml + pio netcdf format (ignored for netcdf4p and netcdf4c) + https://www.unidata.ucar.edu/software/netcdf/docs/data_type.html + + + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + 64bit_offset + + + + + integer + run_pio + env_run.xml + + stride in compute comm of io tasks for each component, if this value is -99 it will + be computed based on PIO_NUMTASKS and number of compute tasks + + + + + + + + + + + + + + + + integer + 1,2 + run_pio + env_run.xml + pio rearranger choice box=1, subset=2 + + $PIO_VERSION + + + + + + + + + + + + + + integer + run_pio + env_run.xml + pio root processor relative to component root + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + + + integer + run_pio + env_run.xml + + pio number of io tasks, if this value is -99 it will be computed based on PIO_STRIDE and + number of tasks + + + -99 + -99 + -99 + -99 + -99 + -99 + -99 + -99 + -99 + + + + + + + + + char + UNSET + test + env_test.xml + Test type name + + + + char + UNSET + test + env_test.xml + Test type descriptor + + + + char + UNSET + test + env_test.xml + Testcase short name + + + + char + UNSET + test + env_test.xml + Case base ID + + + + logical + TRUE,FALSE + TRUE + test + env_test.xml + Is first run of test + + + + char + UNSET + test + env_test.xml + Arguments supplied to create_test + + + + char + UNSET + test + env_test.xml + supplied or computed test id + + + + real + 0.10 + test + env_test.xml + Expected relative memory usage growth for test + + + + real + 0.25 + test + env_test.xml + Expected throughput deviation + + + + logical + TRUE,FALSE + FALSE + test + env_test.xml + Whether to generate a baseline + + + + logical + TRUE,FALSE + FALSE + test + env_test.xml + Whether to compare the baseline + + + + char + UNSET + test + env_test.xml + The tagname we are comparing baselines against + + + + char + UNSET + test + env_test.xml + The tagname we are comparing baselines against + + + + char + /UNSET + test + env_test.xml + The directory where baselines are stored + + + + char + UNSET + test + env_test.xml + The tagname we are generating baselines for + + + + char + UNSET + test + env_test.xml + The tagname we are comparing baselines against + + + + logical + TRUE,FALSE + FALSE + test + env_test.xml + Whether to clean the test after it is built/run + + + + char + UNSET + test + env_test.xml + standard full pathname of the cprnc executable + + + + char + UNSET + user_mods + env_case.xml + path to user mods under TESTS_MODS_DIR or USER_MODS_DIR + + + + + + + + logical + TRUE,FALSE + FALSE + run_coupling + env_run.xml + determine if per ice thickness category fields are passed from ice to ocean - DO NOT EDIT (set by POP build-namelist) + + + + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + run_drv_history + env_run.xml + Sets driver snapshot history file frequency (like REST_OPTION) + + + + integer + + -999 + run_drv_history + env_run.xml + Sets driver snapshot history file frequency (like REST_N) + + + + + integer + + -999 + run_drv_history + env_run.xml + yyyymmdd format, sets coupler snapshot history date (like REST_DATE) + + + + integer + 0,1,2,3,4,5,6 + 0 + run_flags + env_run.xml + Coupler decomposition option. + + + + integer + 0,1,2,3 + 1 + run_flags + env_run.xml + level of debug output, 0=minimum, 1=normal, 2=more, 3=too much + + + + logical + TRUE,FALSE + FALSE + build_component_clm + env_build.xml + TRUE implies CLM is built with support for the PETSc + library. The Variably Saturated Flow Model (VSFM) solver in CLM + uses the PETSc library. In order to use the VSFM solver, CLM + must be built with PETSc support and linking to PETSc must occur + when building the ACME executable. This occurs if this variable + is set to TRUE. Note that is only available on a limited set of + machines/compilers. + + + + + + char + + external_tools + env_run.xml + External script to be run before model completion + + + char + + external_tools + env_run.xml + External script to be run after model completion + + + + + + logical + TRUE,FALSE + external_tools + env_run.xml + Run the external tool pointed to by DATA_ASSIMILATION_SCRIPT after the model run completes + + FALSE + FALSE + FALSE + FALSE + FALSE + FALSE + FALSE + FALSE + + + + + integer + + 1 + external_tools + env_run.xml + Number of model run - data assimilation steps to complete + + + char + + + external_tools + env_run.xml + External script to be run after model completion + + + + + char + job_submission + env_batch.xml + Store user override for queue + + + + char + job_submission + env_batch.xml + Store user override for walltime + + + + char + + + job_submission + env_batch.xml + The machine queue in which to submit the job. Default determined in config_machines.xml can be overwritten by testing + + + + char + + + job_submission + env_batch.xml + The machine wallclock setting. Default determined in config_machines.xml can be overwritten by testing + + + + char + + + job_submission + env_batch.xml + Override the batch submit command this job. Do not include executable or dependencies + + + + char + + job_submission + env_batch.xml + project for project-sensitive build and run paths, and job scripts + + + + char + + job_submission + env_batch.xml + project to charge in scripts if different from PROJECT + + + + char + unknown + case_der + env_case.xml + Apparent version of the model used for this case + + + + logical + TRUE,FALSE + FALSE + job_submission + env_batch.xml + whether the PROJECT value is required on this machine + + + + ========================================= + Notes: + (1) Time period is first four characters of + compset name + ========================================= + + + diff --git a/driver-mct/cime_config/config_component_acme.xml b/driver-mct/cime_config/config_component_acme.xml new file mode 100644 index 000000000000..5d45d90f5161 --- /dev/null +++ b/driver-mct/cime_config/config_component_acme.xml @@ -0,0 +1,830 @@ + + + + + + logical + TRUE,FALSE + TRUE + run_flags + env_run.xml + Turns on component varying thread control in the driver. + Used to set the driver namelist variable "drv_threading". + + + + logical + TRUE,FALSE + TRUE + run_flags + env_run.xml + logical to save timing files in rundir + + + + char + + UNSET + run_flags + env_run.xml + Where to auto archive timing data + + + + integer + 12 + run_flags + env_run.xml + timer output depth + + + + integer + 20 + run_flags + env_run.xml + timer output depth + + + + integer + 12 + run_flags + env_run.xml + timer detail FIXME - add documentation + + + + logical + TRUE,FALSE + TRUE + run_data_archive + env_run.xml + Logical to archive all interim restart files, not just those at eor + If TRUE, perform short term archiving on all interim restart files, + not just those at the end of the run. By default, this value is TRUE. + The restart files are saved under the specific component directory + ($DOUT_S_ROOT/$CASE/$COMPONENT/rest rather than the top-level $DOUT_S_ROOT/$CASE/rest directory). + Interim restart files are created using the REST_N and REST_OPTION variables. + This is for expert users ONLY and requires expert knowledge. + We will not document this further in this guide. + + + + logical + TRUE,FALSE + TRUE + run_flags + env_run.xml + turns on coupler bit-for-bit reproducibility with varying pe counts + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + + ndays + + run_begin_stop_restart + env_run.xml + + sets frequency of full model barrier (same options as STOP_OPTION) for synchronization with BARRIER_N and BARRIER_DATE + + + + + real + + 284.7 + + 367.0 + 367.0 + + run_co2 + env_run.xml + + Mechanism for setting the CO2 value in ppmv for CLM if + CLM_CO2_TYPE is constant POP if OCN_CO2_TYPE is constant. + + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + + run_flags + env_run.xml + Turn on the passing of water isotope fields through the coupler + + + + char + minus1p8,linear_salt,mushy + minus1p8 + run_physics + env_run.xml + Freezing point calculation for salt water. + + + + + + + + char + CESM1_ORIG,CESM1_ORIG_TIGHT,CESM1_MOD,CESM1_MOD_TIGHT,RASM_OPTION1,RASM_OPTION2 + CESM1_MOD_TIGHT + + CESM1_MOD + CESM1_MOD + CESM1_MOD + CESM1_MOD + CESM1_MOD + CESM1_MOD + CESM1_MOD + RASM_OPTION1 + + run_coupling + env_run.xml + + Coupler sequencing option. This is used to set the driver namelist variable cpl_seq_option. + CESM1_ORIG is the cesm1.1 implementation. + CESM1_MOD includes a cesm1.3 mod that swaps ocean merging and atm/ocn flux + computation. + RASM_OPTION1 runs prep ocean before the ocean coupling reducing + most of the lags and field inconsistency but still allowing the ocean to run + concurrently with the ice and atmosphere. + RASM_OPTION2 is similar to RASM_OPTION1 + but sequences the ice model, prep ocean and ocean model in that order. The + ocean model loses some of the concurrency with the ice model. + CESM1_ORIG_TIGHT and CESM1_MOD_TIGHT are consistent with the old variables + ocean_tight_coupling = true in the driver. That namelist is gone and the + cpl_seq_option flags take it's place. + TIGHT coupling makes no sense with the OPTION5 and OPTION6 flags. + + + + + char + none,CO2A,CO2A_OI,CO2B,CO2C,CO2_DMSA + none + + CO2A + none + CO2C + CO2C + CO2A + CO2A + CO2A + CO2A + CO2A_OI + CO2A_OI + + run_coupling + env_run.xml + Activates additional CO2-related fields to be exchanged between components. Possible values are: + + CO2A: sets the driver namelist variable flds_co2a = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere to the land and ocean. + + CO2A_OI: sets the driver namelist variable flds_co2a = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere to the land and ocean. Also sets the driver namelist variable + flds_bgc_oi = .true.; this turns on the transfer of bgc fields between the + ocean and seaice components via the coupler. + + CO2B: sets the driver namelist variable flds_co2b = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere just to the land, and the surface upward flux of CO2 to be + sent from the land back to the atmosphere + + CO2C: sets the driver namelist variable flds_co2c = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere to the land and ocean, and the surface upward flux of CO2 + to be sent from the land and the open ocean back to the atmosphere. + + CO2_DMSA: sets the driver namelist variable flds_co2_dmsa = .true. + + The namelist variables flds_co2a, flds_co2b, flds_co2c and flds_co2_dmsa are + in the namelist group cpl_flds_inparm. + + + + + char + hour,day,year,decade + run_coupling + env_run.xml + day + + year + year + day + day + day + day + day + day + + Base period associated with NCPL coupling frequency. + This xml variable is only used to set the driver namelist variables, + atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt, and esp_dt. + + + + integer + 48 + + 48 + 48 + 48 + 48 + 144 + 288 + 288 + 48 + 48 + 72 + 48 + 4 + 24 + 24 + 24 + 1 + 1 + 1 + 24 + 12 + 12 + 24 + 48 + 48 + 48 + 96 + 96 + 96 + 96 + 48 + 12 + 96 + 96 + 12 + 12 + 96 + 96 + 144 + 144 + 96 + 144 + 144 + 96 + 96 + 72 + 144 + 288 + 48 + 48 + 24 + 24 + 1 + 4 + 4 + + run_coupling + env_run.xml + Number of atm coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist atm_cpl_dt, equal to basedt/ATM_NCPL, + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + 1 + 1 + 24 + 48 + $ATM_NCPL + 12 + 96 + + run_coupling + env_run.xml + Number of land coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist atm_cpl_dt, equal to basedt/LND_NCPL, + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + 1 + 1 + 24 + $ATM_NCPL + + run_coupling + env_run.xml + Number of ice coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist ice_cpl_dt, equal to basedt/ICE_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + 4 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 24 + 12 + 12 + 24 + 48 + 48 + 48 + 48 + 48 + 48 + 96 + + + run_coupling + env_run.xml + Number of ocn coupling intervals per NCPL_BASE_PERIOD. + Thisn is used to set the driver namelist ocn_cpl_dt, equal to basedt/OCN_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + 1 + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + run_coupling + env_run.xml + Number of glc coupling intervals per NCPL_BASE_PERIOD. + + + + char + glc_coupling_period,yearly + glc_coupling_period + run_coupling + env_run.xml + Period at which coupler averages fields sent to GLC. + This supports doing the averaging to GLC less frequently than GLC is called + (i.e., separating the averaging frequency from the calling frequency). + This is useful because there are benefits to only averaging the GLC inputs + as frequently as they are really needed (yearly for CISM), but GLC needs to + still be called more frequently than that in order to support mid-year restarts. + + Setting GLC_AVG_PERIOD to 'glc_coupling_period' means that the averaging is + done exactly when the GLC is called (governed by GLC_NCPL). + + + + + integer + 8 + + 6 + 6 + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + 1 + 1 + 1 + 24 + 8 + 6 + 4 + 8 + + run_coupling + env_run.xml + Number of rof coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist rof_cpl_dt, equal to basedt/ROF_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + run_coupling + env_run.xml + Number of wav coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist wav_cpl_dt, equal to basedt/WAV_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + + run_component_cpl + env_run.xml + + Only used for compsets with DATM and POP (currently C, G and J): + If true, compute albedos to work with daily avg SW down + If false (default), albedos are computed with the assumption that downward + solar radiation from the atm component has a diurnal cycle and zenith-angle + dependence. This is normally the case when using an active atm component + If true, albedos are computed with the assumption that downward + solar radiation from the atm component is a daily average quantity and + does not have a zenith-angle dependence. This is often the case when + using a data atm component. Only used for compsets with DATM and POP (currently C, G and J). + NOTE: This should really depend on the datm forcing and not the compset per se. + So, for example, whether it is set in a J compset should depend on + what datm forcing is used. + + + + + char + off,ocn + off + + ocn + + run_component_cpl + env_run.xml + + Only used for compsets with DATM and POP (currently C, G and J): + If ocn, ocn provides EP balance factor for precipitation. + Provides EP balance factor for precip for POP. A factor computed by + POP is applied to precipitation so that precipitation balances + evaporation and ocn global salinity does not drift. This is intended + for use when coupling POP to a DATM. Only used for C, G and J compsets. + Default is off + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + + nmonths + + run_drv_history + env_run.xml + Sets driver average history file frequency (like REST_OPTION) + + + + char + + -999 + + 1 + + run_drv_history + env_run.xml + Sets driver average history file frequency (like REST_N) + + + + integer + + -999 + run_drv_history + env_run.xml + yyyymmdd format, sets driver average history date (like REST_DATE) + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + TRUE + + run_budgets + env_run.xml + logical that turns on diagnostic budgets for driver + + + + real + + 379.000 + + 284.7 + 284.7 + 284.7 + 0.000001 + 0.000001 + 367.0 + 379.000 + 284.7 + 379.000 + 379.000 + 367.0 + 367.0 + 367.0 + 367.0 + 367.0 + 367.0 + 367.0 + 379.000 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 368.9 + 368.9 + 367.0 + 284.725 + 284.725 + 368.865 + 368.865 + 368.865 + 368.865 + 368.865 + 368.865 + 368.865 + + 0.000001 + 0.000001 + + 284.7 + 368.9 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + 0.000001 + + run_co2 + env_run.xml + This set the namelist values of CO2 ppmv for CAM and CLM. This variables is + introduced to coordinate this value among multiple components. + + + + char + on, off + off + case_def + env_case.xml + If set to off, this component set/ grid specification is not scientifically supported. + If set to on, this component set/ grid specification is scientifically supported + + + + integer + + 0 + + + -3 + -3 + -1 + 1 + 1 + -1 + 1 + -2 + -2 + -5 + -5 + -6 + 0 + 0 + 0 + 0 + 1 + 3 + 1 + 3 + 1 + 3 + 3 + 3 + 3 + 1 + 2 + 2 + 2 + 1 + 1 + + case_cost + env_case.xml + 2**n relative cost of compset where B is 1 (DO NOT EDIT) + + + + integer + 0,1,3,5,10,36 + 10 + + 0 + + run_glc + env_run.xml + Glacier model number of elevation classes, 0 implies no glacier land unit in clm + Used by both CLM and CISM (even if CISM is not running, and only SGLC is used). + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + TRUE + + TRUE + + run_glc + env_run.xml + Whether the glacier component feeds back to the rest of the system + This affects: + (1) Whether CLM updates its areas based on glacier areas sent from GLC + (2) Whether GLC sends fluxes (e.g., calving fluxes) to the coupler + Note that this is set to TRUE by default for TG compsets - even though there are + no feedbacks for TG compsets, this enables extra coupler diagnostics for these + compsets. + + + + char + idmap + run_domain + env_run.xml + ocn2glc flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ocn2glc flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + ocn2glc state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + ocn2glc state mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2ocn flux mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2ocn flux mapping file decomp type + + + + char + idmap + run_domain + env_run.xml + glc2ocn state mapping file + + + + char + X,Y + Y + run_domain + env_run.xml + glc2ocn state mapping file decomp type + + + + integer + + 0 + case_cost + env_case.xml + 2**n relative cost of grid where f19_g15 is 1 (DO NOT EDIT) + + + + integer + + 0 + case_cost + env_case.xml + 2**n relative cost of machine (DO NOT EDIT) + + + + BGC CO2=prog, rad CO2=prog: + BGC CO2=diag, rad CO2=diag: + ECO in POP: + --DO NOT USE FOR LONG SIMULATIONS: + pre-industrial: + present day: + Historical 1850 to 2000 transient: + AMIP for stand-alone cam: + CCMI REFC2 1950 to 2100 transient: + CCMI REFC2 2004 to 2100 transient: + 1948 to 2004 transient: + CCMI REFC1 Free running, 1950 to 2010 transient: + CCMI REFC1 Specified dynamics, 1975 to 2010 transient: + RCP8.5 future scenario: + RCP6.0 future scenario: + RCP4.5 future scenario: + 1955 to 2005 transient: + RCP8.5 future scenario: + RCP6.0 future scenario: + RCP4.5 future scenario: + RCP2.6 future scenario: + RCP4.5 based scenario from 2013 (control for WACCM/CARMA nuclear winter study): + 1992 to 2005 transient: + prescribed meteorology: for stand-alone cam + ARM95 IOP: for stand-alone cam + ARM97 IOP: for stand-alone cam + CLM transient land use: + + pre-industrial (1850) to present day: + -----------------------------WARNING ------------------------------------------------ + "PIPD" compsets use complete forcing data from observed sources + up to the year 2005. Following this period they are a combination of observed sources + (land-use, SST, sea ice, CO2, CH4, N2O) to present day and IPCC RCP4.5 scenario data. + ------------------------------------------------------------------------------------- + + + -----------------------------WARNING ------------------------------------------------ + This compset is not spun-up! In later versions of the model, spun-up initial + conditions will be provided and this warning will be removed. + ------------------------------------------------------------------------------------- + + + diff --git a/driver-mct/cime_config/config_component_cesm.xml b/driver-mct/cime_config/config_component_cesm.xml new file mode 100644 index 000000000000..fc3976d7fa3b --- /dev/null +++ b/driver-mct/cime_config/config_component_cesm.xml @@ -0,0 +1,534 @@ + + + + + + + + + 1972-2004 + 2002-2003 + Historic transient + Twentieth century transient + + CMIP5 rcp 2.6 forcing + CMIP5 rcp 4.5 forcing + CMIP5 rcp 6.0 forcing + CMIP5 rcp 8.5 forcing + Biogeochemistry intercomponent + with diagnostic CO2 + with prognostic CO2 + + + + logical + TRUE,FALSE + FALSE + run_flags + env_run.xml + Turns on component varying thread control in the driver. + Used to set the driver namelist variable "drv_threading". + + + + logical + TRUE,FALSE + FALSE + run_flags + env_run.xml + logical to save timing files in rundir + + + + char + + timing + run_flags + env_run.xml + Where to auto archive timing data + + + + integer + 0 + run_cesm + env_run.xml + Determines number of times profiler is called over the model run period. + This sets values for tprof_option and tprof_n that determine the timing output file frequency + + + + + integer + 2 + run_flags + env_run.xml + timer output depth + + + + integer + 12 + run_flags + env_run.xml + timer output depth + + + + logical + TRUE,FALSE + FALSE + run_data_archive + env_run.xml + Logical to archive all interim restart files, not just those at eor + If TRUE, perform short term archiving on all interim restart files, + not just those at the end of the run. By default, this value is TRUE. + The restart files are saved under the specific component directory + ($DOUT_S_ROOT/$CASE/$COMPONENT/rest rather than the top-level $DOUT_S_ROOT/$CASE/rest directory). + Interim restart files are created using the REST_N and REST_OPTION variables. + This is for expert users ONLY and requires expert knowledge. + We will not document this further in this guide. + + + + logical + TRUE,FALSE + FALSE + run_flags + env_run.xml + turns on coupler bit-for-bit reproducibility with varying pe counts + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + + ndays + + run_begin_stop_restart + env_run.xml + + sets frequency of full model barrier (same options as STOP_OPTION) for synchronization with BARRIER_N and BARRIER_DATE + + + + + char + none,CO2A,CO2B,CO2C + none + + CO2A + none + CO2A + CO2A + CO2A + CO2C + CO2C + + run_coupling + env_run.xml + Activates additional CO2-related fields to be exchanged between components. Possible values are: + + CO2A: sets the driver namelist variable flds_co2a = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere to the land and ocean. + + CO2B: sets the driver namelist variable flds_co2b = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere just to the land, and the surface upward flux of CO2 to be + sent from the land back to the atmosphere + + CO2C: sets the driver namelist variable flds_co2c = .true.; this adds + prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + the atmosphere to the land and ocean, and the surface upward flux of CO2 + to be sent from the land and the open ocean back to the atmosphere. + + The namelist variables flds_co2a, flds_co2b and flds_co2c are in the + namelist group cpl_flds_inparm. + + + + + char + hour,day,year,decade + run_coupling + env_run.xml + day + + year + hour + + Base period associated with NCPL coupling frequency. + This xml variable is only used to set the driver namelist variables, + atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt, and esp_dt. + + + + integer + 48 + + 144 + 288 + 288 + 72 + 48 + 4 + 24 + 24 + 24 + 48 + 1 + 96 + 96 + 96 + 96 + 192 + 192 + 192 + 192 + 384 + 384 + 384 + 144 + 72 + 144 + 288 + 48 + 48 + 24 + 24 + 1 + 4 + 4 + + run_coupling + env_run.xml + Number of atm coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist atm_cpl_dt, equal to basedt/ATM_NCPL, + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + + run_coupling + env_run.xml + Number of land coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist atm_cpl_dt, equal to basedt/LND_NCPL, + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + + run_coupling + env_run.xml + Number of ice coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist ice_cpl_dt, equal to basedt/ICE_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + + 1 + 4 + 24 + 24 + 1 + 1 + 1 + 1 + 1 + 1 + + run_coupling + env_run.xml + Number of ocn coupling intervals per NCPL_BASE_PERIOD. + Thisn is used to set the driver namelist ocn_cpl_dt, equal to basedt/OCN_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + 1 + + 1 + + run_coupling + env_run.xml + Number of glc coupling intervals per NCPL_BASE_PERIOD. + + + + char + glc_coupling_period,yearly + yearly + run_coupling + env_run.xml + Period at which coupler averages fields sent to GLC. + This supports doing the averaging to GLC less frequently than GLC is called + (i.e., separating the averaging frequency from the calling frequency). + This is useful because there are benefits to only averaging the GLC inputs + as frequently as they are really needed (yearly for CISM), but GLC needs to + still be called more frequently than that in order to support mid-year restarts. + + Setting GLC_AVG_PERIOD to 'glc_coupling_period' means that the averaging is + done exactly when the GLC is called (governed by GLC_NCPL). + + IMPORTANT: In order to restart mid-year when running with CISM, you MUST specify GLC_AVG_PERIOD = 'yearly'. + If using GLC_AVG_PERIOD = 'glc_coupling_period' with CISM, you can only restart on year boundaries. + + + + + integer + 8 + + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + 8 + $ATM_NCPL + 1 + + run_coupling + env_run.xml + Number of rof coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist rof_cpl_dt, equal to basedt/ROF_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + integer + $ATM_NCPL + run_coupling + env_run.xml + Number of wav coupling intervals per NCPL_BASE_PERIOD. + This is used to set the driver namelist wav_cpl_dt, equal to basedt/WAV_NCPL + where basedt is equal to NCPL_BASE_PERIOD in seconds. + + + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + FALSE + + run_component_cpl + env_run.xml + + Only used for compsets with DATM and POP (currently C, G and J): + If true, compute albedos to work with daily avg SW down + If false (default), albedos are computed with the assumption that downward + solar radiation from the atm component has a diurnal cycle and zenith-angle + dependence. This is normally the case when using an active atm component + If true, albedos are computed with the assumption that downward + solar radiation from the atm component is a daily average quantity and + does not have a zenith-angle dependence. This is often the case when + using a data atm component. Only used for compsets with DATM and POP (currently C, G and J). + NOTE: This should really depend on the datm forcing and not the compset per se. + So, for example, whether it is set in a J compset should depend on + what datm forcing is used. + + + + + char + off,ocn + off + + ocn + off + + run_component_cpl + env_run.xml + + Only used for compsets with DATM and POP (currently C, G and J): + If ocn, ocn provides EP balance factor for precipitation. + Provides EP balance factor for precip for POP. A factor computed by + POP is applied to precipitation so that precipitation balances + evaporation and ocn global salinity does not drift. This is intended + for use when coupling POP to a DATM. Only used for C, G and J compsets. + Default is off + + + + + char + CESM1_ORIG,CESM1_ORIG_TIGHT,CESM1_MOD,CESM1_MOD_TIGHT,RASM_OPTION1,RASM_OPTION2 + CESM1_MOD_TIGHT + + CESM1_MOD + CESM1_MOD + RASM_OPTION1 + RASM_OPTION1 + CESM1_MOD + CESM1_MOD + CESM1_MOD + CESM1_MOD + + run_coupling + env_run.xml + + Coupler sequencing option. This is used to set the driver namelist variable cpl_seq_option. + CESM1_ORIG is the cesm1.1 implementation. + CESM1_MOD includes a cesm1.3 mod that swaps ocean merging and atm/ocn flux + computation. + RASM_OPTION1 runs prep ocean before the ocean coupling reducing + most of the lags and field inconsistency but still allowing the ocean to run + concurrently with the ice and atmosphere. + RASM_OPTION2 is similar to RASM_OPTION1 + but sequences the ice model, prep ocean and ocean model in that order. The + ocean model loses some of the concurrency with the ice model. + CESM1_ORIG_TIGHT and CESM1_MOD_TIGHT are consistent with the old variables + ocean_tight_coupling = true in the driver. That namelist is gone and the + cpl_seq_option flags take it's place. + TIGHT coupling makes no sense with the OPTION5 and OPTION6 flags. + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + + nmonths + + run_drv_history + env_run.xml + Sets driver average history file frequency (like REST_OPTION) + + + + char + + -999 + + 1 + + run_drv_history + env_run.xml + Sets driver average history file frequency (like REST_N) + + + + integer + + -999 + run_drv_history + env_run.xml + yyyymmdd format, sets driver average history date (like REST_DATE) + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + TRUE + + run_budgets + env_run.xml + logical that turns on diagnostic budgets for driver + + + + real + + 284.7 + + 367.0 + 284.7 + + run_co2 + env_run.xml + + Mechanism for setting the CO2 value in ppmv for + CLM if CLM_CO2_TYPE is constant or for + POP if OCN_CO2_TYPE is constant. + + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + + run_flags + env_run.xml + Turn on the passing of water isotope fields through the coupler + + + + integer + 0,1,3,5,10,36 + 10 + + 0 + + run_glc + env_run.xml + Glacier model number of elevation classes, 0 implies no glacier land unit in clm + Used by both CLM and CISM (even if CISM is not running, and only SGLC is used). + + + + logical + TRUE,FALSE + FALSE + + TRUE + TRUE + + TRUE + + run_glc + env_run.xml + Whether the glacier component feeds back to the rest of the system + This affects: + (1) Whether CLM updates its areas based on glacier areas sent from GLC + (2) Whether GLC sends fluxes (e.g., calving fluxes) to the coupler + Note that this is set to TRUE by default for TG compsets - even though there are + no feedbacks for TG compsets, this enables extra coupler diagnostics for these + compsets. + + + + char + minus1p8,linear_salt,mushy + mushy + run_physics + env_run.xml + Freezing point calculation for salt water. + + + + diff --git a/driver-mct/cime_config/config_compsets.xml b/driver-mct/cime_config/config_compsets.xml new file mode 100644 index 000000000000..ff91128e9dbf --- /dev/null +++ b/driver-mct/cime_config/config_compsets.xml @@ -0,0 +1,110 @@ + + + + + + ========================================= + compset naming convention + ========================================= + The compset longname below has the specified order + atm, lnd, ice, ocn, river, glc wave esp cesm-options + + The notation for the compset longname below is + TIME_ATM[%phys]_LND[%phys]_ICE[%phys]_OCN[%phys]_ROF[%phys]_GLC[%phys]_WAV[%phys][_ESP][_BGC%phys] + + The following compsets are those that can be tested in CIME stand-alone configurations + without any prognostic components. + For the compsets below the following are the only allowable values of the components. + + TIME = Time period (e.g. 2000, HIST, RCP8...) + ATM = [DATM, SATM, XATM] + LND = [DLND, SLND, XLND] + ICE = [DICE, SICE, XICE] + OCN = [DOCN, SOCN, XOCN] + ROF = [DROF, SROF, XROF] + GLC = [ SGLC ] + WAV = [DWAV, SWAV ] + ESP = [DESP, SESP ] + + The OPTIONAL %phys attributes specify submodes of the given system + For example DOCN%DOM is the data ocean model for DOCN + ALL the possible %phys choices for each component are listed + with the -list command for create_newcase + ALL data models must have a %phys option that corresponds to the data model mode + + Each compset node is associated with the following elements + - lname + - alias + - support (optional description of the support level for this compset) + Each compset node can also have the following attributes + - grid (optional regular expression match for grid to work with the compset) + + + + A + 2000_DATM%NYF_SLND_DICE%SSMI_DOCN%DOM_DROF%NYF_SGLC_SWAV + + + + ADSOM + 2000_DATM%NYF_SLND_DICE%SSMI_DOCN%SOM_DROF%NYF_SGLC_SWAV_TEST + + + + ADSOMAQP + 2000_DATM%NYF_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV + + + + ADAQP3 + 2000_DATM%NYF_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV + + + + ADAQPFILE + 2000_DATM%NYF_SLND_SICE_DOCN%AQPFILE_SROF_SGLC_SWAV + + + + ADLND + 2000_SATM_DLND%SCPL_SICE_SOCN_SROF_SGLC_SWAV + + + + ADWAV + 2000_SATM_SLND_SICE_SOCN_SROF_SGLC_DWAV%CLIMO + + + + ADESP + 2000_DATM%NYF_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV_DESP%NOOP + + + + ADESP_TEST + 2000_DATM%NYF_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV_DESP%TEST + + + + AIAF + 2000_DATM%IAF_SLND_DICE%IAF_DOCN%IAF_DROF%IAF_SGLC_SWAV + + + + S + 2000_SATM_SLND_SICE_SOCN_SROF_SGLC_SWAV_SESP + + + + X + 2000_XATM_XLND_XICE_XOCN_XROF_XGLC_XWAV + + + + + + TRUE + + + + diff --git a/driver-mct/cime_config/config_pes.xml b/driver-mct/cime_config/config_pes.xml new file mode 100644 index 000000000000..ad332b3ff030 --- /dev/null +++ b/driver-mct/cime_config/config_pes.xml @@ -0,0 +1,210 @@ + + + + + + + + none + + -1 + -1 + -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 + + + + + + + + + none + + 60 + 60 + 60 + 60 + 60 + 60 + 60 + 60 + 60 + + + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + + + + none + + -8 + -8 + -8 + -8 + -8 + -8 + -8 + -8 + -8 + + + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + + + + none + + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + + + 8 + 8 + 8 + 8 + 8 + 8 + 8 + 8 + 8 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + + + + PE layout for tests + + 64 + 64 + 64 + 64 + 64 + 64 + 64 + 64 + 64 + + + 16 + 16 + 16 + 16 + 16 + 16 + 16 + 16 + 16 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + diff --git a/driver-mct/cime_config/namelist_definition_drv.xml b/driver-mct/cime_config/namelist_definition_drv.xml new file mode 100644 index 000000000000..16d067102704 --- /dev/null +++ b/driver-mct/cime_config/namelist_definition_drv.xml @@ -0,0 +1,4021 @@ + + + + + + + + + + + + + + integer + cime_driver_inst + cime_driver_inst + + Number of CESM driver instances. Only used if MULTI_DRIVER is TRUE. + + + 1 + $NINST_MAX + + + + + + + + + logical + seq_flds + seq_cplflds_inparm + + If set to .true., adds prognostic CO2 and diagnostic CO2 at the lowest + model level to be sent from the atmosphere to the land and ocean. + If CCSM_BGC is set to 'CO2A', then flds_co2a will be set to .true. by default + + + .false. + .true. + + + + + logical + seq_flds + seq_cplflds_inparm + + If set to .true., adds prognostic CO2 and diagnostic CO2 at the lowest + model level to be sent from the atmosphere just to the land, and the + surface upward flux of CO2 to be sent from the land back to the + atmosphere. + If CCSM_BGC is set to 'CO2B', then flds_co2b will be set to .true. by default. + + + .false. + .true. + + + + + logical + seq_flds + seq_cplflds_inparm + + If set to .true., adds prognostic CO2 and diagnostic CO2 at the lowest + model level to be sent from the atmosphere to the land and ocean, and the + surface upward flux of CO2 to be sent from the land and the open ocean + back to the atmosphere. + If CCSM_BGC is set to 'CO2C', then flds_co2c will be set to .true. by default. + + + .false. + .true. + + + + + logical + seq_flds + seq_cplflds_inparm + + If CCSM_BGC is set to 'CO2_DMSA', then flds_co2_dmsa will be set to .true. by default. + + + .false. + .true. + + + + + logical + seq_flds + seq_cplflds_inparm + + If set to .true. BGC fields will be passed back and forth between the ocean and seaice + via the coupler. + + + .false. + .true. + + + + + logical + seq_flds + seq_cplflds_inparm + + Pass water isotopes between components + + + $FLDS_WISO + + + + + integer + seq_flds + seq_cplflds_inparm + + Number of cism elevation classes. Set by the xml variable GLC_NEC in env_run.xml + + + $GLC_NEC + + + + + integer + seq_flds + seq_cplflds_inparm + + Number of sea ice thickness categories. Set by the xml variable ICE_NCAT in env_build.xml + + + $ICE_NCAT + + + + + logical + seq_flds + seq_cplflds_inparm + + .true. if select per ice thickness category fields are passed to the ocean. + Set by the xml variable CPL_I2O_PER_CAT in env_run.xml + + + $CPL_I2O_PER_CAT + + + + + logical + seq_flds + seq_cplflds_inparm + + .true. means that all fields passed to coupler are checked for NaN values + + + .false. + .true. + + + + + + + + + char(200) + seq_flds + seq_cplflds_userspec + + New fields that are user specidied can be added as namelist variables + by the user in the cpl namelist seq_flds_user using the namelist variable + array cplflds_customs. The user specified new fields must follow the + above naming convention. + As an example, say you want to add a new state 'foo' that is passed + from the land to the atm - you would do this as follows + &seq_flds_user + cplflds_custom = 'Sa_foo->a2x', 'Sa_foo->x2a' + / + This would add the field 'Sa_foo' to the character strings defining the + attribute vectors a2x and x2a. It is assumed that code would need to be + introduced in the atm and land components to deal with this new attribute + vector field. + Modify user_nl_cpl to edit this. + + + '' + + + + + + + + + char + expdef + seq_infodata_inparm + acme,cesm + cime model + + cesm + acme + + + + + logical + expdef + seq_infodata_inparm + + true => turn on aquaplanet mode in cam + + + .false. + + + + + integer + expdef + seq_infodata_inparm + + 1 => default sst mode for aquaplanet in cam + + + 1 + + + + + char + expdef + seq_infodata_inparm + + case name. + + + $CASE + + + + + char + expdef + seq_infodata_inparm + + case description. + + + $CASESTR + + + + + + + char + expdef + seq_infodata_inparm + + username documentation + + + $USER + + + + + char + expdef + seq_infodata_inparm + + hostname information, + + + $MACH + + + + + char + expdef + seq_infodata_inparm + + location of timing output. + + + ./timing + + + + + char + expdef + seq_infodata_inparm + + location of timing checkpoint output. + + + ./timing/checkpoints + + + + + char + expdef + seq_infodata_inparm + startup,branch,continue + + mode to start the run up, [startup,branch,continue], + automatically derived from RUN_TYPE in env_run.xml + + + startup + startup + branch + continue + continue + continue + + + + + logical + expdef + seq_infodata_inparm + + Allow same branch casename as reference casename. If $CASE and $REFCASE are the same and the start_type is + not startup, then the value of brnch_retain_casename is set to .true. + + + .false. + + + + + integer + expdef + seq_infodata_inparm + + Level of debug output, 0=minimum, 1=normal, 2=more, 3=too much (default: 1) + + + $INFO_DBUG + + + + + logical + expdef + seq_infodata_inparm + + turns on bfb option in coupler which produce bfb results in the + coupler on different processor counts. (default: .false.) + + + $BFBFLAG + + + + + char + orbital + seq_infodata_inparm + fixed_year,variable_year,fixed_parameters + + orbital model setting. this sets how the orbital mode will be + configured. + "fixed_year" uses the orb_iyear and other orb inputs are ignored. In + this mode, the orbital parameters are constant and based on the year. + "variable_year" uses the orb_iyear and orb_iyear_align. In this mode, + the orbital parameters vary as the model year advances and the model + year orb_iyear_align has the equivalent orbital year of orb_iyear. + "fixed_parameters" uses the orb_eccen, orb_mvelp, and orb_obliq to set + the orbital parameters which then remain constant through the model + integration. [fixed_year, variable_year, fixed_parameters] (default: 'fixed_year'.) + + + fixed_year + + + + + integer + orbital + seq_infodata_inparm + + model year associated with orb_iyear when orb_mode is variable_year. (default: 1990) + + + 1990 + + + + + integer + orbital + seq_infodata_inparm + + year of orbit, used when orb_mode is fixed_year or variable_year. (default: 1990) + + + 1990 + + + + + real + orbital + seq_infodata_inparm + + eccentricity of orbit, used when orb_mode is fixed_parameters. + default: SHR_ORB_UNDEF_REAL (1.e36) (Not currently used in build-namelist) + + + 1.e36 + + + + + real + orbital + seq_infodata_inparm + + location of vernal equinox in longitude degrees, used when orb_mode is fixed_parameters. + default: SHR_ORB_UNDEF_REAL (1.e36)(Not currently used in build-namelist) + + + 1.e36 + + + + + real + orbital + seq_infodata_inparm + + obliquity of orbit in degrees, used when orb_mode is fixed_parameters. + default: SHR_ORB_UNDEF_REAL (1.e36) (Not currently used in build-namelist) + + + 1.e36 + + + + + char + wv_sat + seq_infodata_inparm + GoffGratch,MurphyKoop,Bolton,Flatau + + Type of water vapor saturation vapor pressure scheme employed. 'GoffGratch' for + Goff and Gratch (1946); 'MurphyKoop' for Murphy and Koop (2005); 'Bolton' for + Bolton (1980); 'Flatau' for Flatau, Walko, and Cotton (1992). + Default: GoffGratch + + + GoffGratch + + + + + real + wv_sat + seq_infodata_inparm + + Width of the liquid-ice transition range in mixed-phase water saturation vapor + pressure calculations. The range always ends at 0 degrees Celsius, so this + variable only affects the start of the transition. + Default: 20K + WARNING: CAM is tuned to the default value of this variable. Because it affects + so many different parameterizations, changes to this variable may require a + significant retuning of CAM's cloud physics to give reasonable results. + + + 20.0D0 + + + + + logical + wv_sat + seq_infodata_inparm + + Whether or not to produce lookup tables at init time to use as a cache for + saturation vapor pressure. + Default: .false. + + + .false. + + + + + real + wv_sat + seq_infodata_inparm + + Temperature resolution of saturation vapor pressure lookup tables in Kelvin. + (This is only used if wv_sat_use_tables is .true.) + Default: 1.0 + + + 1.0D0 + + + + + char + control + seq_infodata_inparm + Freezing point calculation for salt water. + + $TFREEZE_SALTWATER_OPTION + + + + + char + control + seq_infodata_inparm + off,ocn + + Only used for C,G compsets: if ocn, ocn provides EP balance factor for precip + + + $CPL_EPBAL + + + + + logical + control + seq_infodata_inparm + + Only used for C,G compsets: if true, compute albedos to work with daily avg SW down + + + $CPL_ALBAV + + + + + char + control + seq_infodata_inparm + on,off,on_if_glc_coupled_fluxes + + Whether to renormalize the surface mass balance (smb) sent from lnd to glc so that the + global integral on the glc grid agrees with the global integral on the lnd grid. + + Unlike most fluxes, smb is remapped with bilinear rather than conservative mapping weights, + so this option is needed for conservation. However, conservation is not required in many + cases, since we often run glc as a diagnostic (one-way-coupled) component. + + Allowable values are: + 'on': always do this renormalization + 'off': never do this renormalization (see WARNING below) + 'on_if_glc_coupled_fluxes': Determine at runtime whether to do this renormalization. + Does the renormalization if we're running a two-way-coupled glc that sends fluxes + to other components (which is the case where we need conservation). + Does NOT do the renormalization if we're running a one-way-coupled glc, or if + we're running a glc-only compset (T compsets). + (In these cases, conservation is not important.) + + Only used if running with a prognostic GLC component. + + WARNING: Setting this to 'off' will break conservation when running with an + evolving, two-way-coupled glc. + + + on_if_glc_coupled_fluxes + + + + + real + control + seq_infodata_inparm + + Wall time limit for run + default: -1.0 + + + -1.0 + + + + + char + control + seq_infodata_inparm + day,month,year + + Force stop at the next month, day, etc when wall_time_limit is hit + default: month + + + month + + + + + logical + control + seq_infodata_inparm + + If true, turn on diurnal cycle in computing atm/ocn fluxes + default: false + + + .false. + + + + + real + control + seq_infodata_inparm + + wind gustiness factor + + + 0.0D0 + + + + + char + mapping + seq_infodata_inparm + + ATM_GRID values passed into driver. + + + $ATM_GRID + + + + + char + mapping + seq_infodata_inparm + + LND_GRID values passed into driver. + + + $LND_GRID + + + + + char + mapping + seq_infodata_inparm + + OCN_GRID values passed into driver. + + + $OCN_GRID + + + + + char + mapping + seq_infodata_inparm + + ICE_GRID values passed into driver. + + + $ICE_GRID + + + + + char + mapping + seq_infodata_inparm + + ROF_GRID values passed into driver. + + + $ROF_GRID + + + + + char + mapping + seq_infodata_inparm + + GLC_GRID values passed into driver. + + + $GLC_GRID + + + + + char + mapping + seq_infodata_inparm + + WAV_GRID values passed into driver. + + + $WAV_GRID + + + + + logical + mapping + seq_infodata_inparm + + invoke pole averaging corrections in shr_map_mod weights generation (default: true) + + + .true. + + + + + char + mapping + seq_infodata_inparm + none,npfix,cart3d,cart3d_diag,cart3d_uvw,cart3d_uvw_diag + + vect_map + turns on the vector mapping option for u and v vector mapping between + atm and ocean grids in the coupler. the options are none, npfix, + cart3d, cart3d_diag, cart3d_uvw, and cart3d_uvw_diag. the none option + results in scalar mapping independently for the u and v field which + tends to generate large errors near the poles. npfix is the + traditional option where the vectors are corrected on the ocean grid + north of the last latitude line of the atmosphere grid. the cart3d + options convert the east (u) and north (v) vectors to 3d (x,y,z) + triplets, and maps those fields before converting back to the east (u) + and north (v) directions. the cart3d ignores the resuling "w" + velocity. the cart3d_uvw calculates the resulting u and v vectors by + preserving the total "u,v,w" speed and the angle of the (u,v) vector. + the _diag options just add diagnotics to the log file about the vector + mapping. + + + $VECT_MAP + + + + + char + mapping + seq_infodata_inparm + ocn,atm,exch + + Grid for atm ocn flux calc (untested) + default: ocn + + + ocn + + + + + logical + mapping + seq_infodata_inparm + + mct alltoall mapping flag + default: false + + + .false. + + + + + logical + mapping + seq_infodata_inparm + + mct vector flag + default: false + + + .false. + + + + + integer + expdef + seq_infodata_inparm + 0,1,2,3,4,5,6 + + cpl decomp option (0=default, 1=comp decomp, 2=rearr comp decomp, 3=new single 1d seg + default: 0 + + + $CPL_DECOMP + + + + + char + expdef + seq_infodata_inparm + CESM1_ORIG,CESM1_MOD,CESM1_ORIG_TIGHT,CESM1_MOD_TIGHT,RASM_OPTION1,RASM_OPTION2 + + Set the coupler sequencing. + + + $CPL_SEQ_OPTION + + + + + logical + budget + seq_infodata_inparm + + logical that turns on diagnostic budgets, false means budgets will never be written + + + $BUDGETS + + + + + logical + history + seq_infodata_inparm + + logical to write an extra initial coupler history file + + + .false. + + + + + integer + budget + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the instantaneous budgets. [0,1,2,3], + written only if BUDGETS variable is true + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets + default: 0 + + + 0 + + + + + integer + budget + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the daily budgets. [0,1,2,3], + written only if do_budgets variable is .true., + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets + default: 0 + + + 0 + + + + + integer + expdef + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the monthy budgets. [0,1,2,3], + written only if do_budgets variable is .true., + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets + default: 1 + + + 1 + + + + + integer + budget + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the annual budgets. [0,1,2,3], + written only if do_budgets variable is .true., + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets + default: 1 + + + 1 + + + + + integer + budget + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the longterm budgets written at the end + of the year. [0,1,2,3], + written only if do_budgets variable is .true., + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets, + default: 1 + + + 1 + + + + + integer + budget + seq_infodata_inparm + 0,1,2,3 + + sets the diagnotics level of the longterm budgets written at the end + of each run. [0,1,2,3], + written only if do_budgets variable is .true., + 0=none, + 1=+net summary budgets, + 2=+detailed lnd/ocn/ice component budgets, + 3=+detailed atm budgets, + default: 0 + + + 0 + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for instantaneous atm to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for 1-hour average atm to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for 1-hour instantaneous atm to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for 3-hour average atm to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for 3-hour average atm to coupler precip fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for daily average atm to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for instantaneous land to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for instantaneous runoff to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + turns on coupler history stream for annual sno to coupler fields. + default: false + + + .false. + + + + + logical + history + seq_infodata_inparm + + writes atm fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes lnd fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes ocn fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes ice fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes rof fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes glc fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes wav fields in coupler average history files. + default: true + + + .true. + + + + + logical + history + seq_infodata_inparm + + writes xao fields in coupler average history files. + default: true + + + .true. + + + + + logical + performance + seq_infodata_inparm + + turn on run time control of threading per pe per component by the driver + default: false + + + $DRV_THREADING + + + + + logical + performance + seq_infodata_inparm + + default: .false. + + + $COMP_RUN_BARRIERS + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in fractions in domain checking + default: 1.0e-02 + + + $EPS_FRAC + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in atm/land masks in domain checking + default: 1.0e-13 + + + $EPS_AMASK + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in atm/land lat/lon in domain checking + default: 1.0e-12 + + + $EPS_AGRID + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in atm/land areas in domain checking + default: 1.0e-07 + + + $EPS_AAREA + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in ocean/ice masks in domain checking + default: 1.0e-06 + + + $EPS_OMASK + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in ocean/ice lon/lat in domain checking + default: 1.0e-2 + + + $EPS_OGRID + + + + + real + domain_check + seq_infodata_inparm + + Error tolerance for differences in ocean/ice lon/lat in domain checking + default: 1.0e-1 + + + $EPS_OAREA + + + + + logical + seq_infodata_inparm + seq_infodata_inparm + + turns on single column mode. set by PTS_MODE in env_case.xml, default: false + + + .false. + .true. + + + + + real + seq_infodata_inparm + seq_infodata_inparm + + grid point latitude associated with single column mode. + if set to -999, ignore this value + + + -999. + $PTS_LAT + + + + + real + seq_infodata_inparm + seq_infodata_inparm + + grid point longitude associated with single column mode. + set by PTS_LON in env_run.xml. + + + -999. + $PTS_LON + + + + + logical + reprosum + seq_infodata_inparm + + Use faster method for reprosum, but one where reproducibility is not always guaranteed. + default: .false. + + + .false. + + + + + real + reprosum + seq_infodata_inparm + + Tolerance for relative error + default: -1.0e-8 + + + -1.0e-8 + + + + + logical + reprosum + seq_infodata_inparm + + Recompute with non-scalable algorithm if reprosum_diffmax is exceeded. + default: .false. + + + .false. + + + + + + + + + integer + time + seq_timemgr_inparm + + atm coupling interval in seconds + set via ATM_NCPL in env_run.xml. + ATM_NCPL is the number of times the atm is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, and has valid values: hour,day,year,decade + + + + + integer + time + seq_timemgr_inparm + + lnd coupling interval in seconds + set via LND_NCPL in env_run.xml. + LND_NCPL is the number of times the lnd is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + + + + + integer + time + seq_timemgr_inparm + + river runoff coupling interval in seconds + currently set by default to 10800 seconds. + default: 10800 + + + + + integer + time + seq_timemgr_inparm + + ice coupling interval in seconds + set via ICE_NCPL in env_run.xml. + ICE_NCPL is the number of times the ice is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + + + + + integer + time + seq_timemgr_inparm + + ocn coupling interval in seconds + set via OCN_NCPL in env_run.xml. + OCN_NCPL is the number of times the ocn is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + + + + + integer + time + seq_timemgr_inparm + + glc coupling interval in seconds + set via GLC_NCPL in env_run.xml. + GLC_NCPL is the number of times the glc is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + + + + + char + time + seq_timemgr_inparm + glc_coupling_period,yearly + + $GLC_AVG_PERIOD + + + Period at which coupler averages fields sent to GLC. + This supports doing the averaging to GLC less frequently than GLC is called + (i.e., separating the averaging frequency from the calling frequency). + This is useful because there are benefits to only averaging the GLC inputs + as frequently as they are really needed (yearly for CISM), but GLC needs to + still be called more frequently than that in order to support mid-year restarts. + + Setting glc_avg_period to 'glc_coupling_period' means that the averaging is + done exactly when the GLC is called (governed by GLC_NCPL). + + + + + integer + time + seq_timemgr_inparm + + wav coupling interval in seconds + set via WAV_NCPL in env_run.xml. + WAV_NCPL is the number of times the wav is coupled per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is also set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + + + + + integer + time + seq_timemgr_inparm + + esp run interval in seconds + esp_cpl_dt is the number of times the esp is run per NCPL_BASE_PERIOD + NCPL_BASE_PERIOD is set in env_run.xml and is the base period + associated with NCPL coupling frequency, nad has valid values: hour,day,year,decade + default value set by buildnml to be the pause interval if pause is active + otherwise, it is set to the shortest component coupling time + + + -999 + + + + + integer + time + seq_timemgr_inparm + + atm coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + lnd coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + ice coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + ocn coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + glc coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + wav coupling interval offset in seconds default: 0 + + + 0 + + + + + integer + time + seq_timemgr_inparm + + esp coupling interval offset in seconds default: 0 + + + 0 + + + + + logical + time + seq_timemgr_inparm + + true => ESP component runs after driver 'pause cycle' If any + component 'pauses' (see PAUSE_OPTION, + PAUSE_N and DATA_ASSIMILATION_XXX XML + variables), the ESP component (if present) will be run to + process the component 'pause' (restart) files and set any + required 'resume' signals. If true, esp_cpl_dt and + esp_cpl_offset settings are ignored. default: true + + + .true. + + + + + char + time + seq_timemgr_inparm + NO_LEAP,GREGORIAN + + calendar in use. [NO_LEAP, GREOGORIAN]. + set by CALENDAR in env_build.xml + + + $CALENDAR + + + + + integer + time + seq_timemgr_inparm + + Run start date in yyyymmdd format, only used for startup and hybrid runs. + default: 00010101 + + + 00010101 + + + + + integer + time + seq_timemgr_inparm + + Start time-of-day in universal time (seconds), should be between zero and 86400 + default: 0 + + + $START_TOD + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + sets the run length with stop_n and stop_ymd + stop_option alarms are: + [none/never], turns option off + [nstep/s] , stops every stop_n nsteps , relative to current run start time + [nsecond/s] , stops every stop_n nseconds, relative to current run start time + [nminute/s] , stops every stop_n nminutes, relative to current run start time + [nhour/s] , stops every stop_n nhours , relative to current run start time + [nday/s] , stops every stop_n ndays , relative to current run start time + [nmonth/s] , stops every stop_n nmonths , relative to current run start time + [monthly/s] , stops every month , relative to current run start time + [nyear/s] , stops every stop_n nyears , relative to current run start time + [date] , stops at stop_ymd value + [ifdays0] , stops at stop_n calendar day value and seconds equal 0 + [end] , stops at end + + + $STOP_OPTION + + + + + integer + time + seq_timemgr_inparm + + Sets the run length with stop_option and stop_ymd + + + $STOP_N + + + + + integer + time + seq_timemgr_inparm + + date in yyyymmdd format, sets the run length with stop_option and stop_n, + can be in addition to stop_option and stop_n, negative value implies off + + + $STOP_DATE + + + + + char + expdef + seq_infodata_inparm + + + Driver restart filename. + (NOTE: Normally THIS IS NOT USED -- Set with RUN_REFCASE and RUN_REFDATE) + + + str_undefined + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,monthly,nmonth,nyears,nyear,date,ifdays0,end + + sets the restart frequency with restart_n and restart_ymd + restart_option alarms are: + [none/never], turns option off + [nstep/s] , restarts every restart_n nsteps , relative to current run start time + [nsecond/s] , restarts every restart_n nseconds, relative to current run start time + [nminute/s] , restarts every restart_n nminutes, relative to current run start time + [nhour/s] , restarts every restart_n nhours , relative to current run start time + [nday/s] , restarts every restart_n ndays , relative to current run start time + [monthly/s] , restarts every month , relative to current run start time + [nmonth/s] , restarts every restart_n nmonths , relative to current run start time + [nyear/s] , restarts every restart_n nyears , relative to current run start time + [date] , restarts at restart_ymd value + [ifdays0] , restarts at restart_n calendar day value and seconds equal 0 + [end] , restarts at end + + + $REST_OPTION + + + + + integer + time + seq_timemgr_inparm + + Sets model restart writes with restart_option and restart_ymd (same options as stop_n) + + + $REST_N + + + + + integer + time + seq_timemgr_inparm + + Date in yyyymmdd format, sets model restart write date with rest_option and restart_n + default: STOP_N + + + $REST_DATE + + + + + logical + time + seq_timemgr_inparm + + true => write restarts at end of run + forces a restart write at the end of the run in addition to any + setting associated with rest_option. default=true. this setting + will be set to false if restart_option is none or never. + default: false + + + .false. + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + coupler history snapshot option (used with history_n and history_ymd) + set by HIST_OPTION in env_run.xml. + history_option alarms are: + [none/never], turns option off + [nstep/s] , history snapshot every history_n nsteps , relative to current run start time + [nsecond/s] , history snapshot every history_n nseconds, relative to current run start time + [nminute/s] , history snapshot every history_n nminutes, relative to current run start time + [nhour/s] , history snapshot every history_n nhours , relative to current run start time + [nday/s] , history snapshot every history_n ndays , relative to current run start time + [monthly/s] , history snapshot every month , relative to current run start time + [nmonth/s] , history snapshot every history_n nmonths , relative to current run start time + [nyear/s] , history snapshot every history_n nyears , relative to current run start time + [date] , history snapshot at history_ymd value + [ifdays0] , history snapshot at history_n calendar day value and seconds equal 0 + [end] , history snapshot at end + + + $HIST_OPTION + + + + + integer + time + seq_timemgr_inparm + + sets coupler snapshot history file frequency (like restart_n) + set by HIST_N in env_run.xml. + + + $HIST_N + + + + + integer + time + seq_timemgr_inparm + + date associated with history_option date. yyyymmdd format. + set by HIST_DATE in env_run.xml. + + + $HIST_DATE + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + coupler time average history option (used with histavg_n and histavg_ymd) + set by AVGHIST_OPTION in env_run.xml. + histavg_option alarms are: + [none/never], turns option off + [nstep/s] , history snapshot every histavg_n nsteps , relative to current run start time + [nsecond/s] , history snapshot every histavg_n nseconds, relative to current run start time + [nminute/s] , history snapshot every histavg_n nminutes, relative to current run start time + [nhour/s] , history snapshot every histavg_n nhours , relative to current run start time + [nday/s] , history snapshot every histavg_n ndays , relative to current run start time + [monthly/s] , history snapshot every month , relative to current run start time + [nmonth/s] , history snapshot every histavg_n nmonths , relative to current run start time + [nyear/s] , history snapshot every histavg_n nyears , relative to current run start time + [date] , history snapshot at histavg_ymd value + [ifdays0] , history snapshot at histavg_n calendar day value and seconds equal 0 + [end] , history snapshot at end + + + $AVGHIST_OPTION + + + + + integer + time + seq_timemgr_inparm + + Sets coupler time-average history file frequency (like restart_option) + set by AVGHIST_N in env_run.xml. + + + $AVGHIST_N + + + + + integer + time + seq_timemgr_inparm + + date associated with histavg_option date. yyyymmdd format. + set by AVGHIST_DATE in env_run.xml. + + + $AVGHIST_DATE + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,monthly,nmonth,nyears,nyear,date,ifdays0,end + + sets the driver barrier frequency to sync models across all tasks with barrier_n and barrier_ymd + barrier_option alarms are like restart_option + default: never + + + $BARRIER_OPTION + + + + + integer + time + seq_timemgr_inparm + + Sets model barriers with barrier_option and barrier_ymd (same options as stop_n) + default: 1 + + + $BARRIER_N + + + + + integer + time + seq_timemgr_inparm + + Date in yyyymmdd format, sets model barriers date with barrier_option and barrier_n + + + $BARRIER_DATE + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + Sets timing output file frequency (like rest_option but relative to run start date) + tprof_option alarms are: + [none/never], turns option off + [nstep/s] , every tprof_n nsteps , relative to current run start time + [nsecond/s] , every tprof_n nseconds, relative to current run start time + [nminute/s] , every tprof_n nminutes, relative to current run start time + [nhour/s] , every tprof_n nhours , relative to current run start time + [nday/s] , every tprof_n ndays , relative to current run start time + [monthly/s] , every month , relative to current run start time + [nmonth/s] , every tprof_n nmonths , relative to current run start time + [nyear/s] , every tprof_n nyears , relative to current run start time + [date] , at tprof_ymd value + [ifdays0] , at tprof_n calendar day value and seconds equal 0 + [end] , at end + + + never + + + + + integer + time + seq_timemgr_inparm + + Sets timing output file frequency (like restart_n) + + + -999 + + + + + integer + time + seq_timemgr_inparm + + yyyymmdd format, sets timing output file date (like restart_date) + + + -999 + + + + + char + time + seq_timemgr_inparm + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear + + sets the pause frequency with pause_n + pause_option alarms are: + [none/never], turns option off + [nstep/s] , pauses every pause_n nsteps , relative to start or last pause time + [nsecond/s] , pauses every pause_n nseconds, relative to start or last pause time + [nminute/s] , pauses every pause_n nminutes, relative to start or last pause time + [nhour/s] , pauses every pause_n nhours , relative to start or last pause time + [nday/s] , pauses every pause_n ndays , relative to start or last pause time + [nmonth/s] , pauses every pause_n nmonths , relative to start or last pause time + [monthly/s] , pauses every month , relative to start or last pause time + [nyear/s] , pauses every pause_n nyears , relative to start or last pause time + + + $PAUSE_OPTION + + + + + integer + time + seq_timemgr_inparm + + Sets the pause frequency with pause_option + + + $PAUSE_N + + + + + char + driver + seq_infodata_inparm + + + Ending suffix "postfix" for output log files. + + + .log + + + + + char + drv_history + seq_infodata_inparm + + + Root directory for driver output files + + + ./ + + + + + real + driver + seq_infodata_inparm + + Abort model if coupler timestep wallclock time exceeds this value, ignored if 0, + if < 0 then use abs(max_cplstep_time)*cktime as the threshold. + default: 0 + + + 0.0 + + + + + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the atm components. + set by NTASKS_ATM in env_configure.xml. + + + $NTASKS_ATM + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the atm component. + set by NTHRDS_ATM in env_configure.xml. + + + $NTHRDS_ATM + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the atm component. + set by ROOTPE_ATM in env_configure.xml. + + + $ROOTPE_ATM + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the atm component. + set by PSTRID_ATM in env_configure.xml. + + + $PSTRID_ATM + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance atms (if there are more than 1) + + + $NINST_ATM_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the lnd components. + set by NTASKS_LND in env_configure.xml. + + + $NTASKS_LND + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the lnd component. + set by NTHRDS_LND in env_configure.xml. + + + $NTHRDS_LND + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the lnd component. + set by ROOTPE_LND in env_configure.xml. + + + $ROOTPE_LND + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the lnd component. + set by PSTRID_LND in env_configure.xml. + + + $PSTRID_LND + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance lnds (if there are more than 1) + + + $NINST_LND_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the ice components. + set by NTASKS_ICE in env_configure.xml. + + + $NTASKS_ICE + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the ice component. + set by NTHRDS_ICE in env_configure.xml. + + + $NTHRDS_ICE + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the ice component. + set by ROOTPE_ICE in env_configure.xml. + + + $ROOTPE_ICE + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the ice component. + set by PSTRID_ICE in env_configure.xml. + + + $PSTRID_ICE + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance ices (if there are more than 1) + + + $NINST_ICE_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the ocn components. + set by NTASKS_OCN in env_configure.xml. + + + $NTASKS_OCN + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the ocn component. + set by NTHRDS_OCN in env_configure.xml. + + + $NTHRDS_OCN + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the ocn component. + set by ROOTPE_OCN in env_configure.xml. + + + $ROOTPE_OCN + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the ocn component. + set by PSTRID_OCN in env_configure.xml. default: 1 + + + $PSTRID_OCN + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance ocns (if there are more than 1) + + + $NINST_OCN_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the glc components. + set by NTASKS_GLC in env_configure.xml. + + + $NTASKS_GLC + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the glc component. + set by NTHRDS_GLC in env_configure.xml. + + + $NTHRDS_GLC + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the glc component. + set by ROOTPE_GLC in env_configure.xml. + + + $ROOTPE_GLC + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the glc component. + set by PSTRID_GLC in env_configure.xml. + + + $PSTRID_GLC + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance glcs (if there are more than 1) + + + $NINST_GLC_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the wav components. + set by NTASKS_WAV in env_configure.xml. + + + $NTASKS_WAV + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the wav component. + set by NTHRDS_WAV in env_configure.xml. + + + $NTHRDS_WAV + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the wav component. + set by ROOTPE_WAV in env_configure.xml. + + + $ROOTPE_WAV + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the wav component. + set by PSTRID_WAV in env_configure.xml. + + + $PSTRID_WAV + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance wavs (if there are more than 1) + + + $NINST_WAV_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the lnd components. + set by NTASKS_LND in env_configure.xml. + + + $NTASKS_ROF + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the lnd component. + set by NTHRDS_ROF in env_configure.xml. + + + $NTHRDS_ROF + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the lnd component. + set by ROOTPE_LND in env_configure.xml. + + + $ROOTPE_ROF + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the lnd component. + set by PSTRID_LND in env_configure.xml. + + + $PSTRID_ROF + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance lnds (if there are more than 1) + + + $NINST_ROF_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the esp components. + set by NTASKS_ESP in env_configure.xml. + + + $NTASKS_ESP + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the esp component. + set by NTHRDS_ESP in env_configure.xml. + + + $NTHRDS_ESP + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the esp component. + set by ROOTPE_ESP in env_configure.xml. + + + $ROOTPE_ESP + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the esp component. + set by PSTRID_ESP in env_configure.xml. + + + $PSTRID_ESP + + + + + char + ccsm_pes + ccsm_pes + concurrent,sequential + + Layout of multi-instance external system processor (if there are more than 1) + + + $NINST_ESP_LAYOUT + + + + + integer + ccsm_pes + ccsm_pes + + the number of mpi tasks assigned to the cpl components. + set by NTASKS_CPL in env_configure.xml. + + + $NTASKS_CPL + + + + + integer + ccsm_pes + ccsm_pes + + the number of threads per mpi task for the cpl component. + set by NTHRDS_CPL in env_configure.xml. + + + $NTHRDS_CPL + + + + + integer + ccsm_pes + ccsm_pes + + the global mpi task rank of the root processor assigned to the cpl component. + set by ROOTPE_CPL in env_configure.xml. + + + $ROOTPE_CPL + + + + + integer + ccsm_pes + ccsm_pes + + the mpi global processors stride associated with the mpi tasks for the cpl component. + set by PSTRID_CPL in env_configure.xml. + + + $PSTRID_CPL + + + + + + + + + + logical + performance + prof_inparm + + + + .true. + + + + + logical + performance + prof_inparm + + + + .false. + + + + + logical + performance + prof_inparm + + + + .false. + .true. + + + + + logical + performance + prof_inparm + + + + .false. + + + + + integer + performance + prof_inparm + + + + $TIMER_LEVEL + + + + + integer + performance + prof_inparm + + + + 0 + + + + + integer + performance + prof_inparm + + + + $TIMER_DETAIL + + + + + integer + performance + prof_inparm + + + + 4 + 2 + 1 + 3 + + + + + logical + performance + prof_inparm + + default: .false. + + + .false. + + + + + logical + performance + prof_inparm + + default: .false. + + + .false. + + + + + integer + performance + prof_inparm + + default: 1 + + + 1 + + + + + logical + performance + prof_inparm + + default: .false. + + + $PROFILE_PAPI_ENABLE + + + + + + + + + + char + performance + papi_inparm + + See gptl_papi.c for the list of valid values + + + PAPI_FP_OPS + + + + + char + performance + papi_inparm + + See gptl_papi.c for the list of valid values + + + PAPI_NO_CTR + + + + + char + performance + papi_inparm + + See gptl_papi.c for the list of valid values + + + PAPI_NO_CTR + + + + + char + performance + papi_inparm + + See gptl_papi.c for the list of valid values + + + PAPI_NO_CTR + + + + + + + + + logical + pio + pio_default_inparm + + future asynchronous IO capability (not currently supported). + If pio_async_interface is .true. or {component}_PIO_* variable is not set or set to -99 + the component variable will be set using the pio_* value. + default: .false. + + + $PIO_ASYNC_INTERFACE + + + + + integer + pio + pio_default_inparm + 0,1,2,3,4,5,6 + + pio debug level + valid values: 0,1,2,3,4,5,6 + + + $PIO_DEBUG_LEVEL + + + + + integer + pio + pio_default_inparm + + blocksize for pio box rearranger + + + $PIO_BLOCKSIZE + + + + + integer + pio + pio_default_inparm + + pio buffer size limit + + + $PIO_BUFFER_SIZE_LIMIT + + + + + char + pio + pio_default_inparm + p2p,coll,default + + pio rearranger communication type. + valid values: p2p, coll, default + + + $PIO_REARR_COMM_TYPE + + + + + char + pio + pio_default_inparm + 2denable,io2comp,comp2io,disable,default + + pio rearranger communication flow control direction. + + + $PIO_REARR_COMM_FCD + + + + + integer + pio + pio_default_inparm + + pio rearranger communication max pending req (comp2io) + + + $PIO_REARR_COMM_MAX_PEND_REQ_COMP2IO + + + + + logical + pio + pio_default_inparm + + pio rearranger communication option: Enable handshake (comp2io) + + + $PIO_REARR_COMM_ENABLE_HS_COMP2IO + + + + + logical + pio + pio_default_inparm + + pio rearranger communication option: Enable isends (comp2io) + + + $PIO_REARR_COMM_ENABLE_ISEND_COMP2IO + + + + + integer + pio + pio_default_inparm + + pio rearranger communication max pending req (io2comp) + + + $PIO_REARR_COMM_MAX_PEND_REQ_IO2COMP + + + + + logical + pio + pio_default_inparm + + pio rearranger communication option: Enable handshake (io2comp) + + + $PIO_REARR_COMM_ENABLE_HS_IO2COMP + + + + + logical + pio + pio_default_inparm + + pio rearranger communication option: Enable isends (io2comp) + default: .false. + + + $PIO_REARR_COMM_ENABLE_ISEND_IO2COMP + + + + + + + + + char + mapping + abs + seq_maps + + atm to ocn flux mapping file for fluxes + + + $ATM2OCN_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to ocn state mapping file for states + + + $ATM2OCN_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to ocn state mapping file for velocity + + + $ATM2OCN_VMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_VMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ocn to atm mapping file for fluxes + + + $OCN2ATM_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $OCN2ATM_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ocn to atm mapping file for states + + + $OCN2ATM_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $OCN2ATM_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to ice flux mapping file for fluxes + + + $ATM2OCN_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to ice state mapping file for states + + + $ATM2OCN_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to ice state mapping file for velocity + + + $ATM2OCN_VMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2OCN_VMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ice to atm mapping file for fluxes + + + $OCN2ATM_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $OCN2ATM_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ice to atm mapping file for states + + + $OCN2ATM_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $OCN2ATM_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to land mapping file for fluxes + + + $ATM2LND_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2LND_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to land mapping file for states + + + $ATM2LND_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2LND_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + land to atm mapping file for fluxes + + + $LND2ATM_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $LND2ATM_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + land to atm mapping file for states + + + $LND2ATM_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $LND2ATM_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + lnd to runoff conservative mapping file + + + $LND2ROF_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $LND2ROF_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + runoff to lnd conservative mapping file + + + $ROF2LND_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ROF2LND_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + runoff to ocn area overlap conservative mapping file + + + $ROF2OCN_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ROF2OCN_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + glc to ocn runoff conservative mapping file + + + $GLC2OCN_RMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $GLC2OCN_RMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + glc to ice runoff conservative mapping file + + + $GLC2ICE_RMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $GLC2ICE_RMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + runoff to ocn nearest neighbor plus smoothing conservative mapping file + + + $ROF2OCN_LIQ_RMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ROF2OCN_LIQ_RMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + runoff to ocn nearest neighbor plus smoothing conservative mapping file + + + $ROF2OCN_ICE_RMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ROF2OCN_ICE_RMAPTYPE + X + + + + + + char + mapping + abs + seq_maps + + land to glc mapping file for fluxes + + + $LND2GLC_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $LND2GLC_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + land to glc mapping file for states + + + $LND2GLC_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $LND2GLC_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + glc to land mapping file for fluxes + + + $GLC2LND_FMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $GLC2LND_FMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + glc to land mapping file for states + + + $GLC2LND_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $GLC2LND_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + atm to wav state mapping file for states + + + $ATM2WAV_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ATM2WAV_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ocn to wav state mapping file for states + + + $OCN2WAV_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $OCN2WAV_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + ice to wav state mapping file for states + + + $ICE2WAV_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $ICE2WAV_SMAPTYPE + X + + + + + char + mapping + abs + seq_maps + + wav to ocn state mapping file for states + + + $WAV2OCN_SMAPNAME + + + + + char + mapping + seq_maps + + The type of mapping desired, either "source" or "destination" mapping. + X is associated with rearrangement of the source grid to the + destination grid and then local mapping. Y is associated with mapping + on the source grid and then rearrangement and sum to the destination + grid. + + + $WAV2OCN_SMAPTYPE + X + + + + + char(10) + drv_physics + default_settings + + List of files to merge together that contains drv_flds_in namelists + The paths are relative to the case directory. drv_flds_in include the namelists that + the driver reads and gives information on additional fields to be passed to different + components that need to look at the same data. + + + Buildconf/camconf/drv_flds_in,Buildconf/clmconf/drv_flds_in + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component atm + + + $DATA_ASSIMILATION_ATM + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component CPL + + + $DATA_ASSIMILATION_CPL + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component ocn + + + $DATA_ASSIMILATION_OCN + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component wav + + + $DATA_ASSIMILATION_WAV + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component glc + + + $DATA_ASSIMILATION_GLC + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component rof + + + $DATA_ASSIMILATION_ROF + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component ice + + + $DATA_ASSIMILATION_ICE + + + + + logical + data_assimilation + seq_timemgr_inparm + + Whether Data Assimilation is on for component lnd + + + $DATA_ASSIMILATION_LND + + + + diff --git a/driver-mct/cime_config/namelist_definition_drv_flds.xml b/driver-mct/cime_config/namelist_definition_drv_flds.xml new file mode 100644 index 000000000000..08847103afde --- /dev/null +++ b/driver-mct/cime_config/namelist_definition_drv_flds.xml @@ -0,0 +1,148 @@ + + + + + + + + + + + + + + char + abs + drv_flds_in + megan_emis_nl + + File containing MEGAN emissions factors. Includes the list of MEGAN compounds that can be + used in the Comp_Name variable on the file. + + + + + char(100) + drv_flds_in + megan_emis_nl + + MEGAN specifier. This is in the form of: Chem-compound = megan_compound(s) + where megan_compound(s) can be the sum of megan compounds with a "+" between them. + In each equation, the item to the left of the equal sign is a CAM chemistry compound, the + items to the right are compounds known to the MEGAN model (single or combinations). + For example: megan_specifier = 'ISOP = isoprene', 'C10H16 = pinene_a + carene_3 + thujene_a' + + + + + logical + drv_flds_in + megan_emis_nl + + MEGAN mapped isoprene emissions factors switch + If TRUE then use mapped MEGAN emissions factors for isoprene. + + + + + char(150) + drv_flds_in + drv_physics + + List of possible MEGAN compounds to use + (the list used by the simulation is on the megan_factors_file as the Comp_Name) + + + + + + + + + char + dry-deposition + drydep_inparm + xactive_lnd,xactive_atm,table + + Where dry deposition is calculated (from land, atmosphere, or from a table) + This specifies the method used to calculate dry + deposition velocities of gas-phase chemical species. The available methods are: + 'table' - prescribed method in CAM + 'xactive_atm' - interactive method in CAM + 'xactive_lnd' - interactive method in CLM + + + + + char(300) + dry-deposition + drydep_inparm + + List of species that undergo dry deposition. + + + + + + + + + char(2) + nitrogen deposition + ndep_inparm + + List of nitrogen deposition fluxes to be sent from CAM to surfae models. + + + + + + + + + char + abs + Fire_emissions + fire_emis_nl + + File containing fire emissions factors. + + + + + char(100) + Fire_emissions + fire_emis_nl + + Fire emissions specifier. + + + + + logical + Fire_emissions + fire_emis_nl + + If ture fire emissions are input into atmosphere as elevated forcings. + Otherwise they are treated as surface emissions. + + + + + + + + + char + carma + carma_inparm + + List of fluxes needed by the CARMA model, from CLM to CAM. + + + + diff --git a/driver-mct/cime_config/namelist_definition_modelio.xml b/driver-mct/cime_config/namelist_definition_modelio.xml new file mode 100644 index 000000000000..ea5d47f0a4ae --- /dev/null +++ b/driver-mct/cime_config/namelist_definition_modelio.xml @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + integer + pio + pio_inparm + + stride of tasks in pio used generically, component based value takes precedent. + + + $CPL_PIO_STRIDE + $ATM_PIO_STRIDE + $LND_PIO_STRIDE + $OCN_PIO_STRIDE + $ICE_PIO_STRIDE + $ROF_PIO_STRIDE + $GLC_PIO_STRIDE + $WAV_PIO_STRIDE + -99 + + + + + integer + pio + pio_inparm + + io task root in pio used generically, component based value takes precedent. + + + $CPL_PIO_ROOT + $ATM_PIO_ROOT + $LND_PIO_ROOT + $OCN_PIO_ROOT + $ICE_PIO_ROOT + $ROF_PIO_ROOT + $GLC_PIO_ROOT + $WAV_PIO_ROOT + -99 + + + + + integer + pio + pio_inparm + -99,1,2 + + Rearranger method for pio 1=box, 2=subset. + + + $CPL_PIO_REARRANGER + $ATM_PIO_REARRANGER + $LND_PIO_REARRANGER + $OCN_PIO_REARRANGER + $ICE_PIO_REARRANGER + $ROF_PIO_REARRANGER + $GLC_PIO_REARRANGER + $WAV_PIO_REARRANGER + -99 + + + + + integer + pio + pio_inparm + + number of io tasks in pio used generically, component based value takes precedent. + + + $CPL_PIO_NUMTASKS + $ATM_PIO_NUMTASKS + $LND_PIO_NUMTASKS + $OCN_PIO_NUMTASKS + $ICE_PIO_NUMTASKS + $ROF_PIO_NUMTASKS + $GLC_PIO_NUMTASKS + $WAV_PIO_NUMTASKS + -99 + + + + + char*64 + pio + pio_inparm + netcdf,pnetcdf,netcdf4p,netcdf4c,default + + io type in pio used generically, component based value takes precedent. + valid values: netcdf, pnetcdf, netcdf4p, netcdf4c, default + + + $CPL_PIO_TYPENAME + $ATM_PIO_TYPENAME + $LND_PIO_TYPENAME + $OCN_PIO_TYPENAME + $ICE_PIO_TYPENAME + $ROF_PIO_TYPENAME + $GLC_PIO_TYPENAME + $WAV_PIO_TYPENAME + nothing + + + + + char*64 + pio + pio_inparm + classic,64bit_offset,64bit_data + + format of netcdf files created by pio, ignored if + PIO_TYPENAME is netcdf4p or netcdf4c. 64bit_data only + supported in netcdf 4.4.0 or newer + + + $CPL_PIO_NETCDF_FORMAT + $ATM_PIO_NETCDF_FORMAT + $LND_PIO_NETCDF_FORMAT + $OCN_PIO_NETCDF_FORMAT + $ICE_PIO_NETCDF_FORMAT + $ROF_PIO_NETCDF_FORMAT + $GLC_PIO_NETCDF_FORMAT + $WAV_PIO_NETCDF_FORMAT + + + + + + + + + char*256 + modelio + modelio + input directory (no longer needed) + + UNSET + + + + + char*256 + modelio + modelio + directory for output log files + + UNSET + + + + + char*256 + modelio + modelio + name of component output log file + + UNSET + + + + diff --git a/driver-mct/cime_config/testdefs/testlist_drv.xml b/driver-mct/cime_config/testdefs/testlist_drv.xml new file mode 100644 index 000000000000..12309561e468 --- /dev/null +++ b/driver-mct/cime_config/testdefs/testlist_drv.xml @@ -0,0 +1,635 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/driver-mct/cime_config/testdefs/testmods_dirs/drv/5steps/shell_commands b/driver-mct/cime_config/testdefs/testmods_dirs/drv/5steps/shell_commands new file mode 100644 index 000000000000..c72c4cfb8208 --- /dev/null +++ b/driver-mct/cime_config/testdefs/testmods_dirs/drv/5steps/shell_commands @@ -0,0 +1,2 @@ +./xmlchange STOP_OPTION="nsteps" + diff --git a/driver-mct/cime_config/testdefs/testmods_dirs/drv/default/shell_commands b/driver-mct/cime_config/testdefs/testmods_dirs/drv/default/shell_commands new file mode 100755 index 000000000000..180e38db21d5 --- /dev/null +++ b/driver-mct/cime_config/testdefs/testmods_dirs/drv/default/shell_commands @@ -0,0 +1,2 @@ +./xmlchange HIST_OPTION=ndays +./xmlchange HIST_N=1 diff --git a/driver-mct/cime_config/testdefs/testmods_dirs/drv/som/shell_commands b/driver-mct/cime_config/testdefs/testmods_dirs/drv/som/shell_commands new file mode 100644 index 000000000000..f3a70e7e662e --- /dev/null +++ b/driver-mct/cime_config/testdefs/testmods_dirs/drv/som/shell_commands @@ -0,0 +1,2 @@ +./xmlchange DOCN_SOM_FILENAME="pop_frc.1x1d.090130.nc" + diff --git a/driver-mct/cime_config/user_nl_cpl b/driver-mct/cime_config/user_nl_cpl new file mode 100644 index 000000000000..a2095360793b --- /dev/null +++ b/driver-mct/cime_config/user_nl_cpl @@ -0,0 +1,19 @@ +!------------------------------------------------------------------------ +! Users should ONLY USE user_nl_cpl to change namelists variables +! for namelist variables in drv_in (except for the ones below) and +! any keyword/values in seq_maps.rc +! Users should add ALL user specific namelist and seq_maps.rc changes below +! using the following syntax +! namelist_var = new_namelist_value +! or +! mapname = new_map_name +! For example to change the default value of ocn2atm_fmapname to 'foo' use +! ocn2atm_fmapname = 'foo' +! +! Note that some namelist variables MAY NOT be changed in user_nl_cpl - +! they are defined in a $CASEROOT xml file and must be changed with +! xmlchange. +! +! For example, rather than set username to 'foo' in user_nl_cpl, call +! ./xmlchange USER=foo +!------------------------------------------------------------------------ diff --git a/driver-mct/main/CMakeLists.txt b/driver-mct/main/CMakeLists.txt new file mode 100644 index 000000000000..d18de153ec8a --- /dev/null +++ b/driver-mct/main/CMakeLists.txt @@ -0,0 +1,9 @@ +list(APPEND drv_sources + component_type_mod.F90 + map_glc2lnd_mod.F90 + map_lnd2rof_irrig_mod.F90 + seq_map_mod.F90 + seq_map_type_mod.F90 + ) + +sourcelist_to_parent(drv_sources) diff --git a/driver-mct/main/cime_comp_mod.F90 b/driver-mct/main/cime_comp_mod.F90 new file mode 100644 index 000000000000..3720bad4d0d3 --- /dev/null +++ b/driver-mct/main/cime_comp_mod.F90 @@ -0,0 +1,4128 @@ +module cime_comp_mod + +!------------------------------------------------------------------------------- +! +! Purpose: Main program for CIME cpl7. Can have different +! land, sea-ice, and ocean models plugged in at compile-time. +! These models can be either: stub, dead, data, or active +! components or some combination of the above. +! +! stub -------- Do nothing. +! dead -------- Send analytic data back. +! data -------- Send data back interpolated from input files. +! prognostic -- Prognostically simulate the given component. +! +! Method: Call appropriate initialization, run (time-stepping), and +! finalization routines. +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! share code & libs + !---------------------------------------------------------------------------- + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use shr_const_mod, only: shr_const_cday + use shr_file_mod, only: shr_file_setLogLevel, shr_file_setLogUnit + use shr_file_mod, only: shr_file_setIO, shr_file_getUnit, shr_file_freeUnit + use shr_scam_mod, only: shr_scam_checkSurface + use shr_map_mod, only: shr_map_setDopole + use shr_mpi_mod, only: shr_mpi_min, shr_mpi_max + use shr_mpi_mod, only: shr_mpi_bcast, shr_mpi_commrank, shr_mpi_commsize + use shr_mem_mod, only: shr_mem_init, shr_mem_getusage + use shr_cal_mod, only: shr_cal_date2ymd, shr_cal_ymd2date, shr_cal_advdateInt + use shr_orb_mod, only: shr_orb_params + use shr_frz_mod, only: shr_frz_freezetemp_init + use shr_reprosum_mod, only: shr_reprosum_setopts + use mct_mod ! mct_ wrappers for mct lib + use perf_mod + use ESMF + + !---------------------------------------------------------------------------- + ! component model interfaces (init, run, final methods) + !---------------------------------------------------------------------------- + + use atm_comp_mct , only: atm_init=>atm_init_mct, atm_run=>atm_run_mct, atm_final=>atm_final_mct + use lnd_comp_mct , only: lnd_init=>lnd_init_mct, lnd_run=>lnd_run_mct, lnd_final=>lnd_final_mct + use ocn_comp_mct , only: ocn_init=>ocn_init_mct, ocn_run=>ocn_run_mct, ocn_final=>ocn_final_mct + use ice_comp_mct , only: ice_init=>ice_init_mct, ice_run=>ice_run_mct, ice_final=>ice_final_mct + use glc_comp_mct , only: glc_init=>glc_init_mct, glc_run=>glc_run_mct, glc_final=>glc_final_mct + use wav_comp_mct , only: wav_init=>wav_init_mct, wav_run=>wav_run_mct, wav_final=>wav_final_mct + use rof_comp_mct , only: rof_init=>rof_init_mct, rof_run=>rof_run_mct, rof_final=>rof_final_mct + use esp_comp_mct , only: esp_init=>esp_init_mct, esp_run=>esp_run_mct, esp_final=>esp_final_mct + + !---------------------------------------------------------------------------- + ! cpl7 modules + !---------------------------------------------------------------------------- + + ! mpi comm data & routines, plus logunit and loglevel + use seq_comm_mct, only: CPLID, GLOID, logunit, loglevel + use seq_comm_mct, only: ATMID, LNDID, OCNID, ICEID, GLCID, ROFID, WAVID, ESPID + use seq_comm_mct, only: ALLATMID,ALLLNDID,ALLOCNID,ALLICEID,ALLGLCID,ALLROFID,ALLWAVID,ALLESPID + use seq_comm_mct, only: CPLALLATMID,CPLALLLNDID,CPLALLOCNID,CPLALLICEID + use seq_comm_mct, only: CPLALLGLCID,CPLALLROFID,CPLALLWAVID,CPLALLESPID + use seq_comm_mct, only: CPLATMID,CPLLNDID,CPLOCNID,CPLICEID,CPLGLCID,CPLROFID,CPLWAVID,CPLESPID + use seq_comm_mct, only: num_inst_atm, num_inst_lnd, num_inst_rof + use seq_comm_mct, only: num_inst_ocn, num_inst_ice, num_inst_glc + use seq_comm_mct, only: num_inst_wav, num_inst_esp + use seq_comm_mct, only: num_inst_xao, num_inst_frc, num_inst_phys + use seq_comm_mct, only: num_inst_total, num_inst_max + use seq_comm_mct, only: seq_comm_iamin, seq_comm_name, seq_comm_namelen + use seq_comm_mct, only: seq_comm_init, seq_comm_setnthreads, seq_comm_getnthreads + use seq_comm_mct, only: seq_comm_getinfo => seq_comm_setptrs + use seq_comm_mct, only: cpl_inst_tag + + ! clock & alarm routines and variables + use seq_timemgr_mod, only: seq_timemgr_type + use seq_timemgr_mod, only: seq_timemgr_clockInit + use seq_timemgr_mod, only: seq_timemgr_clockAdvance + use seq_timemgr_mod, only: seq_timemgr_clockPrint + use seq_timemgr_mod, only: seq_timemgr_EClockGetData + use seq_timemgr_mod, only: seq_timemgr_alarmIsOn + use seq_timemgr_mod, only: seq_timemgr_histavg_type + use seq_timemgr_mod, only: seq_timemgr_type_never + use seq_timemgr_mod, only: seq_timemgr_alarm_restart + use seq_timemgr_mod, only: seq_timemgr_alarm_stop + use seq_timemgr_mod, only: seq_timemgr_alarm_datestop + use seq_timemgr_mod, only: seq_timemgr_alarm_history + use seq_timemgr_mod, only: seq_timemgr_alarm_atmrun + use seq_timemgr_mod, only: seq_timemgr_alarm_lndrun + use seq_timemgr_mod, only: seq_timemgr_alarm_ocnrun + use seq_timemgr_mod, only: seq_timemgr_alarm_icerun + use seq_timemgr_mod, only: seq_timemgr_alarm_glcrun + use seq_timemgr_mod, only: seq_timemgr_alarm_glcrun_avg + use seq_timemgr_mod, only: seq_timemgr_alarm_ocnnext + use seq_timemgr_mod, only: seq_timemgr_alarm_tprof + use seq_timemgr_mod, only: seq_timemgr_alarm_histavg + use seq_timemgr_mod, only: seq_timemgr_alarm_rofrun + use seq_timemgr_mod, only: seq_timemgr_alarm_wavrun + use seq_timemgr_mod, only: seq_timemgr_alarm_esprun + use seq_timemgr_mod, only: seq_timemgr_alarm_barrier + use seq_timemgr_mod, only: seq_timemgr_alarm_pause + use seq_timemgr_mod, only: seq_timemgr_pause_active + use seq_timemgr_mod, only: seq_timemgr_pause_component_active + use seq_timemgr_mod, only: seq_timemgr_pause_component_index + + ! "infodata" gathers various control flags into one datatype + use seq_infodata_mod, only: seq_infodata_putData, seq_infodata_GetData + use seq_infodata_mod, only: seq_infodata_init, seq_infodata_exchange + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_orb_variable_year + use seq_infodata_mod, only: seq_infodata_print, seq_infodata_init2 + + ! domain related routines + use seq_domain_mct, only : seq_domain_check + + ! history file routines + use seq_hist_mod, only : seq_hist_write, seq_hist_writeavg, seq_hist_writeaux + + ! restart file routines + use seq_rest_mod, only : seq_rest_read, seq_rest_write + + ! flux calc routines + use seq_flux_mct, only: seq_flux_init_mct, seq_flux_initexch_mct, seq_flux_ocnalb_mct + use seq_flux_mct, only: seq_flux_atmocn_mct, seq_flux_atmocnexch_mct + + ! domain fraction routines + use seq_frac_mct, only : seq_frac_init, seq_frac_set + + ! i/o subroutines + use seq_io_mod, only : seq_io_cpl_init + + ! rearrange type routines + use cplcomp_exchange_mod, only: seq_mctext_decomp + + ! diagnostic routines + use seq_diag_mct, only : seq_diag_zero_mct , seq_diag_avect_mct, seq_diag_lnd_mct + use seq_diag_mct, only : seq_diag_rof_mct , seq_diag_ocn_mct , seq_diag_atm_mct + use seq_diag_mct, only : seq_diag_ice_mct , seq_diag_accum_mct, seq_diag_print_mct + + ! list of fields transferred between components + use seq_flds_mod, only : seq_flds_a2x_fluxes, seq_flds_x2a_fluxes + use seq_flds_mod, only : seq_flds_i2x_fluxes, seq_flds_x2i_fluxes + use seq_flds_mod, only : seq_flds_l2x_fluxes, seq_flds_x2l_fluxes + use seq_flds_mod, only : seq_flds_o2x_fluxes, seq_flds_x2o_fluxes + use seq_flds_mod, only : seq_flds_g2x_fluxes, seq_flds_x2g_fluxes + use seq_flds_mod, only : seq_flds_w2x_fluxes, seq_flds_x2w_fluxes + use seq_flds_mod, only : seq_flds_r2x_fluxes, seq_flds_x2r_fluxes + use seq_flds_mod, only : seq_flds_set + + ! component type and accessor functions + use component_type_mod , only: component_get_iamin_compid, component_get_suffix + use component_type_mod , only: component_get_name, component_get_c2x_cx + use component_type_mod , only: atm, lnd, ice, ocn, rof, glc, wav, esp + use component_mod , only: component_init_pre + use component_mod , only: component_init_cc, component_init_cx, component_run, component_final + use component_mod , only: component_init_areacor, component_init_aream + use component_mod , only: component_exch, component_diag + + ! prep routines (includes mapping routines between components and merging routines) + use prep_lnd_mod + use prep_ice_mod + use prep_wav_mod + use prep_rof_mod + use prep_glc_mod + use prep_ocn_mod + use prep_atm_mod + use prep_aoflux_mod + + !--- mapping routines --- + use seq_map_type_mod + use seq_map_mod ! generic mapping + + ! --- timing routines --- + use t_drv_timers_mod + + implicit none + + private + + public cime_pre_init1, cime_pre_init2, cime_init, cime_run, cime_final + public timing_dir, mpicom_GLOID + +#include + + !---------------------------------------------------------------------------- + ! temporary variables + !---------------------------------------------------------------------------- + + !- from prep routines (arrays of instances) + type(mct_aVect) , pointer :: a2x_ox(:) => null() + type(mct_aVect) , pointer :: o2x_ax(:) => null() + type(mct_aVect) , pointer :: xao_ox(:) => null() + type(mct_aVect) , pointer :: xao_ax(:) => null() + + !- from component type (single instance inside array of components) + type(mct_aVect) , pointer :: o2x_ox => null() + type(mct_aVect) , pointer :: a2x_ax => null() + + character(len=CL) :: suffix + logical :: iamin_id + logical :: iamroot_id + integer :: mpicom + character(len=seq_comm_namelen) :: compname + + !---------------------------------------------------------------------------- + ! domains & related + !---------------------------------------------------------------------------- + + !--- domain fractions (only defined on cpl pes) --- + type(mct_aVect) , pointer :: fractions_ax(:) ! Fractions on atm grid, cpl processes + type(mct_aVect) , pointer :: fractions_lx(:) ! Fractions on lnd grid, cpl processes + type(mct_aVect) , pointer :: fractions_ix(:) ! Fractions on ice grid, cpl processes + type(mct_aVect) , pointer :: fractions_ox(:) ! Fractions on ocn grid, cpl processes + type(mct_aVect) , pointer :: fractions_gx(:) ! Fractions on glc grid, cpl processes + type(mct_aVect) , pointer :: fractions_rx(:) ! Fractions on rof grid, cpl processes + type(mct_aVect) , pointer :: fractions_wx(:) ! Fractions on wav grid, cpl processes + + !--- domain equivalent 2d grid size --- + integer :: atm_nx, atm_ny ! nx, ny of 2d grid, if known + integer :: lnd_nx, lnd_ny + integer :: ice_nx, ice_ny + integer :: ocn_nx, ocn_ny + integer :: rof_nx, rof_ny + integer :: glc_nx, glc_ny + integer :: wav_nx, wav_ny + + !---------------------------------------------------------------------------- + ! Infodata: inter-model control flags, domain info + !---------------------------------------------------------------------------- + + type (seq_infodata_type), target :: infodata ! single instance for cpl and all comps + + !---------------------------------------------------------------------------- + ! time management + !---------------------------------------------------------------------------- + + type (seq_timemgr_type), SAVE :: seq_SyncClock ! array of all clocks & alarm + type (ESMF_Clock), target :: EClock_d ! driver clock + type (ESMF_Clock), target :: EClock_a ! atmosphere clock + type (ESMF_Clock), target :: EClock_l ! land clock + type (ESMF_Clock), target :: EClock_o ! ocean clock + type (ESMF_Clock), target :: EClock_i ! ice clock + type (ESMF_Clock), target :: EClock_g ! glc clock + type (ESMF_Clock), target :: EClock_r ! rof clock + type (ESMF_Clock), target :: EClock_w ! wav clock + type (ESMF_Clock), target :: EClock_e ! esp clock + + logical :: restart_alarm ! restart alarm + logical :: history_alarm ! history alarm + logical :: histavg_alarm ! history alarm + logical :: stop_alarm ! stop alarm + logical :: atmrun_alarm ! atm run alarm + logical :: lndrun_alarm ! lnd run alarm + logical :: icerun_alarm ! ice run alarm + logical :: ocnrun_alarm ! ocn run alarm + logical :: ocnnext_alarm ! ocn run alarm on next timestep + logical :: glcrun_alarm ! glc run alarm + logical :: glcrun_avg_alarm ! glc run averaging alarm + logical :: rofrun_alarm ! rof run alarm + logical :: wavrun_alarm ! wav run alarm + logical :: esprun_alarm ! esp run alarm + logical :: tprof_alarm ! timing profile alarm + logical :: barrier_alarm ! barrier alarm + logical :: t1hr_alarm ! alarm every hour + logical :: t2hr_alarm ! alarm every two hours + logical :: t3hr_alarm ! alarm every three hours + logical :: t6hr_alarm ! alarm every six hours + logical :: t12hr_alarm ! alarm every twelve hours + logical :: t24hr_alarm ! alarm every twentyfour hours + logical :: t1yr_alarm ! alarm every year, at start of year + logical :: pause_alarm ! pause alarm + integer :: drv_index ! seq_timemgr index for driver + + real(r8) :: days_per_year = 365.0 ! days per year + + integer :: dtime ! dt of one coupling interval + integer :: ncpl ! number of coupling intervals per day + integer :: ymd ! Current date (YYYYMMDD) + integer :: year ! Current date (YYYY) + integer :: month ! Current date (MM) + integer :: day ! Current date (DD) + integer :: tod ! Current time of day (seconds) + integer :: ymdtmp ! temporary date (YYYYMMDD) + integer :: todtmp ! temporary time of day (seconds) + character(CL) :: orb_mode ! orbital mode + character(CS) :: tfreeze_option ! Freezing point calculation + integer :: orb_iyear ! orbital year + integer :: orb_iyear_align ! associated with model year + integer :: orb_cyear ! orbital year for current orbital computation + integer :: orb_nyear ! orbital year associated with currrent model year + real(r8) :: orb_eccen ! orbital eccentricity + real(r8) :: orb_obliq ! obliquity in degrees + real(r8) :: orb_mvelp ! moving vernal equinox long + real(r8) :: orb_obliqr ! Earths obliquity in rad + real(r8) :: orb_lambm0 ! Mean long of perihelion at vernal equinox (radians) + real(r8) :: orb_mvelpp ! moving vernal equinox long + real(r8) :: wall_time_limit ! wall time limit in hours + real(r8) :: wall_time ! current wall time used + character(CS) :: force_stop_at ! force stop at next (month, day, etc) + logical :: force_stop ! force the model to stop + integer :: force_stop_ymd ! force stop ymd + integer :: force_stop_tod ! force stop tod + + !--- for documenting speed of the model --- + character( 8) :: dstr ! date string + character(10) :: tstr ! time string + integer :: begStep, endStep ! Begining and ending step number + character(CL) :: calendar ! calendar name + real(r8) :: simDays ! Number of simulated days + real(r8) :: SYPD ! Simulated years per day + real(r8) :: Time_begin ! Start time + real(r8) :: Time_end ! Ending time + real(r8) :: Time_bstep ! Start time + real(r8) :: Time_estep ! Ending time + real(r8) :: time_brun ! Start time + real(r8) :: time_erun ! Ending time + real(r8) :: cktime ! delta time + real(r8) :: cktime_acc(10) ! cktime accumulator array 1 = all, 2 = atm, etc + integer :: cktime_cnt(10) ! cktime counter array + real(r8) :: max_cplstep_time + character(CL) :: timing_file ! Local path to tprof filename + character(CL) :: timing_dir ! timing directory + character(CL) :: tchkpt_dir ! timing checkpoint directory + + !---------------------------------------------------------------------------- + ! control flags + !---------------------------------------------------------------------------- + + logical :: atm_present ! .true. => atm is present + logical :: lnd_present ! .true. => land is present + logical :: ice_present ! .true. => ice is present + logical :: ocn_present ! .true. => ocn is present + logical :: glc_present ! .true. => glc is present + logical :: glclnd_present ! .true. => glc is computing land coupling + logical :: glcocn_present ! .true. => glc is computing ocean runoff + logical :: glcice_present ! .true. => glc is computing icebergs + logical :: rofice_present ! .true. => rof is computing icebergs + logical :: rof_present ! .true. => rof is present + logical :: flood_present ! .true. => rof is computing flood + logical :: wav_present ! .true. => wav is present + logical :: esp_present ! .true. => esp is present + + logical :: atm_prognostic ! .true. => atm comp expects input + logical :: lnd_prognostic ! .true. => lnd comp expects input + logical :: ice_prognostic ! .true. => ice comp expects input + logical :: iceberg_prognostic ! .true. => ice comp can handle iceberg input + logical :: ocn_prognostic ! .true. => ocn comp expects input + logical :: ocnrof_prognostic ! .true. => ocn comp expects runoff input + logical :: glc_prognostic ! .true. => glc comp expects input + logical :: rof_prognostic ! .true. => rof comp expects input + logical :: wav_prognostic ! .true. => wav comp expects input + logical :: esp_prognostic ! .true. => esp comp expects input + + logical :: atm_c2_lnd ! .true. => atm to lnd coupling on + logical :: atm_c2_ocn ! .true. => atm to ocn coupling on + logical :: atm_c2_ice ! .true. => atm to ice coupling on + logical :: atm_c2_wav ! .true. => atm to wav coupling on + logical :: lnd_c2_atm ! .true. => lnd to atm coupling on + logical :: lnd_c2_rof ! .true. => lnd to rof coupling on + logical :: lnd_c2_glc ! .true. => lnd to glc coupling on + logical :: ocn_c2_atm ! .true. => ocn to atm coupling on + logical :: ocn_c2_ice ! .true. => ocn to ice coupling on + logical :: ocn_c2_wav ! .true. => ocn to wav coupling on + logical :: ice_c2_atm ! .true. => ice to atm coupling on + logical :: ice_c2_ocn ! .true. => ice to ocn coupling on + logical :: ice_c2_wav ! .true. => ice to wav coupling on + logical :: rof_c2_lnd ! .true. => rof to lnd coupling on + logical :: rof_c2_ocn ! .true. => rof to ocn coupling on + logical :: rof_c2_ice ! .true. => rof to ice coupling on + logical :: glc_c2_lnd ! .true. => glc to lnd coupling on + logical :: glc_c2_ocn ! .true. => glc to ocn coupling on + logical :: glc_c2_ice ! .true. => glc to ice coupling on + logical :: wav_c2_ocn ! .true. => wav to ocn coupling on + + logical :: dead_comps ! .true. => dead components + logical :: esmf_map_flag ! .true. => use esmf for mapping + + logical :: areafact_samegrid ! areafact samegrid flag + logical :: single_column ! scm mode logical + real(r8) :: scmlon ! single column lon + real(r8) :: scmlat ! single column lat + logical :: aqua_planet ! aqua planet mode + real(r8) :: nextsw_cday ! radiation control + logical :: atm_aero ! atm provides aerosol data + + character(CL) :: cpl_seq_option ! coupler sequencing option + logical :: skip_ocean_run ! skip the ocean model first pass + logical :: cpl2ocn_first ! use to call initial cpl2ocn timer + logical :: run_barriers ! barrier the component run calls + + character(CS) :: aoflux_grid ! grid for a/o flux calc: atm xor ocn + character(CS) :: vect_map ! vector mapping type + + character(CL) :: atm_gnam ! atm grid + character(CL) :: lnd_gnam ! lnd grid + character(CL) :: ocn_gnam ! ocn grid + character(CL) :: ice_gnam ! ice grid + character(CL) :: rof_gnam ! rof grid + character(CL) :: glc_gnam ! glc grid + character(CL) :: wav_gnam ! wav grid + + logical :: samegrid_ao ! samegrid atm and ocean + logical :: samegrid_al ! samegrid atm and land + logical :: samegrid_lr ! samegrid land and rof + logical :: samegrid_oi ! samegrid ocean and ice + logical :: samegrid_ro ! samegrid runoff and ocean + logical :: samegrid_aw ! samegrid atm and wave + logical :: samegrid_ow ! samegrid ocean and wave + logical :: samegrid_lg ! samegrid glc and land + logical :: samegrid_og ! samegrid glc and ocean + logical :: samegrid_ig ! samegrid glc and ice + logical :: samegrid_alo ! samegrid atm, lnd, ocean + + logical :: read_restart ! local read restart flag + character(CL) :: rest_file ! restart file path + filename + + logical :: shr_map_dopole ! logical for dopole in shr_map_mod + logical :: domain_check ! .true. => check consistency of domains + logical :: reprosum_use_ddpdd ! setup reprosum, use ddpdd + real(r8) :: reprosum_diffmax ! setup reprosum, set rel_diff_max + logical :: reprosum_recompute ! setup reprosum, recompute if tolerance exceeded + + logical :: output_perf = .false. ! require timing data output for this pe + logical :: in_first_day = .true. ! currently simulating first day + + !--- history & budgets --- + logical :: do_budgets ! heat/water budgets on + logical :: do_histinit ! initial hist file + logical :: do_histavg ! histavg on or off + logical :: do_hist_r2x ! create aux files: r2x + logical :: do_hist_l2x ! create aux files: l2x + logical :: do_hist_a2x24hr ! create aux files: a2x + logical :: do_hist_l2x1yr ! create aux files: l2x + logical :: do_hist_a2x ! create aux files: a2x + logical :: do_hist_a2x3hrp ! create aux files: a2x 3hr precip + logical :: do_hist_a2x3hr ! create aux files: a2x 3hr states + logical :: do_hist_a2x1hri ! create aux files: a2x 1hr instantaneous + logical :: do_hist_a2x1hr ! create aux files: a2x 1hr + integer :: budget_inst ! instantaneous budget flag + integer :: budget_daily ! daily budget flag + integer :: budget_month ! monthly budget flag + integer :: budget_ann ! annual budget flag + integer :: budget_ltann ! long term budget flag for end of year writing + integer :: budget_ltend ! long term budget flag for end of run writing + + character(CL) :: hist_a2x_flds = & + 'Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf' + + character(CL) :: hist_a2x3hrp_flds = & + 'Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl' + + character(CL) :: hist_a2x24hr_flds = & + 'Faxa_bcphiwet:Faxa_bcphodry:Faxa_bcphidry:Faxa_ocphiwet:Faxa_ocphidry:& + &Faxa_ocphodry:Faxa_dstwet1:Faxa_dstdry1:Faxa_dstwet2:Faxa_dstdry2:Faxa_dstwet3:& + &Faxa_dstdry3:Faxa_dstwet4:Faxa_dstdry4:Sa_co2prog:Sa_co2diag' + + character(CL) :: hist_a2x1hri_flds = & + 'Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf' + + character(CL) :: hist_a2x1hr_flds = & + 'Sa_u:Sa_v' + + character(CL) :: hist_a2x3hr_flds = & + 'Sa_z:Sa_topo:Sa_u:Sa_v:Sa_tbot:Sa_ptem:Sa_shum:Sa_dens:Sa_pbot:Sa_pslv:Faxa_lwdn:& + &Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl:& + &Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf:& + &Sa_co2diag:Sa_co2prog' + + ! --- other --- + integer :: ka,km,k1,k2,k3 ! aVect field indices + integer :: ocnrun_count ! number of times ocn run alarm went on + logical :: exists ! true if file exists + integer :: ierr ! MPI error return + integer :: rc ! return code + + character(*), parameter :: NLFileName = "drv_in" ! input namelist filename + + integer :: info_debug = 0 ! local info_debug level + + !---------------------------------------------------------------------------- + ! memory monitoring + !---------------------------------------------------------------------------- + real(r8) :: msize,msize0,msize1 ! memory size (high water) + real(r8) :: mrss ,mrss0 ,mrss1 ! resident size (current memory use) + + !---------------------------------------------------------------------------- + ! threading control + !---------------------------------------------------------------------------- + integer :: nthreads_GLOID ! OMP global number of threads + integer :: nthreads_CPLID ! OMP cpl number of threads + integer :: nthreads_ATMID ! OMP atm number of threads + integer :: nthreads_LNDID ! OMP lnd number of threads + integer :: nthreads_ICEID ! OMP ice number of threads + integer :: nthreads_OCNID ! OMP ocn number of threads + integer :: nthreads_GLCID ! OMP glc number of threads + integer :: nthreads_ROFID ! OMP glc number of threads + integer :: nthreads_WAVID ! OMP wav number of threads + integer :: nthreads_ESPID ! OMP esp number of threads + + integer :: pethreads_GLOID ! OMP number of threads per task + + logical :: drv_threading ! driver threading control + + !---------------------------------------------------------------------------- + ! communicator groups and related + !---------------------------------------------------------------------------- + integer :: global_comm + integer :: mpicom_GLOID ! MPI global communicator + integer :: mpicom_CPLID ! MPI cpl communicator + integer :: mpicom_OCNID ! MPI ocn communicator for ensemble member 1 + + integer :: mpicom_CPLALLATMID ! MPI comm for CPLALLATMID + integer :: mpicom_CPLALLLNDID ! MPI comm for CPLALLLNDID + integer :: mpicom_CPLALLICEID ! MPI comm for CPLALLICEID + integer :: mpicom_CPLALLOCNID ! MPI comm for CPLALLOCNID + integer :: mpicom_CPLALLGLCID ! MPI comm for CPLALLGLCID + integer :: mpicom_CPLALLROFID ! MPI comm for CPLALLROFID + integer :: mpicom_CPLALLWAVID ! MPI comm for CPLALLWAVID + + integer :: iam_GLOID ! pe number in global id + logical :: iamin_CPLID ! pe associated with CPLID + logical :: iamroot_GLOID ! GLOID masterproc + logical :: iamroot_CPLID ! CPLID masterproc + + logical :: iamin_CPLALLATMID ! pe associated with CPLALLATMID + logical :: iamin_CPLALLLNDID ! pe associated with CPLALLLNDID + logical :: iamin_CPLALLICEID ! pe associated with CPLALLICEID + logical :: iamin_CPLALLOCNID ! pe associated with CPLALLOCNID + logical :: iamin_CPLALLGLCID ! pe associated with CPLALLGLCID + logical :: iamin_CPLALLROFID ! pe associated with CPLALLROFID + logical :: iamin_CPLALLWAVID ! pe associated with CPLALLWAVID + + + !---------------------------------------------------------------------------- + ! complist: list of comps on this pe + !---------------------------------------------------------------------------- + + ! allow enough room for names of all physical components + coupler, + ! where each string can be up to (max_inst_name_len+1) characters + ! long (+1 allows for a space before each name) + character(len=(seq_comm_namelen+1)*(num_inst_phys+1)) :: complist + + !---------------------------------------------------------------------------- + ! comp_num_: unique component number for each component type + !---------------------------------------------------------------------------- + integer, parameter :: comp_num_atm = 1 + integer, parameter :: comp_num_lnd = 2 + integer, parameter :: comp_num_ice = 3 + integer, parameter :: comp_num_ocn = 4 + integer, parameter :: comp_num_glc = 5 + integer, parameter :: comp_num_rof = 6 + integer, parameter :: comp_num_wav = 7 + integer, parameter :: comp_num_esp = 8 + + !---------------------------------------------------------------------------- + ! misc + !---------------------------------------------------------------------------- + + integer, parameter :: ens1=1 ! use first instance of ensemble only + integer, parameter :: fix1=1 ! temporary hard-coding to first ensemble, needs to be fixed + integer :: eai, eli, eoi, eii, egi, eri, ewi, eei, exi, efi ! component instance counters + + !---------------------------------------------------------------------------- + ! formats + !---------------------------------------------------------------------------- + character(*), parameter :: subname = '(seq_mct_drv)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + character(*), parameter :: F0L = "('"//subname//" : ', A, L6 )" + character(*), parameter :: F0I = "('"//subname//" : ', A, 2i8 )" + character(*), parameter :: F01 = "('"//subname//" : ', A, 2i8, 3x, A )" + character(*), parameter :: F0R = "('"//subname//" : ', A, 2g23.15 )" + character(*), parameter :: FormatA = '(A,": =============== ", A44, " ===============")' + character(*), parameter :: FormatD = '(A,": =============== ", A20,2I8,8x, " ===============")' + character(*), parameter :: FormatR = '(A,": =============== ", A31,F12.3,1x, " ===============")' + character(*), parameter :: FormatQ = '(A,": =============== ", A20,2F10.2,4x," ===============")' +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!******************************************************************************* +!=============================================================================== + +subroutine cime_pre_init1() + use shr_pio_mod, only : shr_pio_init1, shr_pio_init2 + use seq_comm_mct, only: num_inst_driver + !---------------------------------------------------------- + !| Initialize MCT and MPI communicators and IO + !---------------------------------------------------------- + + integer, dimension(num_inst_total) :: comp_id, comp_comm, comp_comm_iam + logical :: comp_iamin(num_inst_total) + character(len=seq_comm_namelen) :: comp_name(num_inst_total) + integer :: i, it + integer :: driver_id + integer :: driver_comm + + call mpi_init(ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_init') + call mpi_comm_dup(MPI_COMM_WORLD, global_comm, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_dup') + + comp_comm = MPI_COMM_NULL + time_brun = mpi_wtime() + + !--- Initialize multiple driver instances, if requested --- + call cime_cpl_init(global_comm, driver_comm, num_inst_driver, driver_id) + + call shr_pio_init1(num_inst_total,NLFileName, driver_comm) + ! + ! If pio_async_interface is true Global_comm is MPI_COMM_NULL on the servernodes + ! and server nodes do not return from shr_pio_init2 + ! + ! if (Global_comm /= MPI_COMM_NULL) then + + if (num_inst_driver > 1) then + call seq_comm_init(global_comm, driver_comm, NLFileName, drv_comm_ID=driver_id) + write(cpl_inst_tag,'("_",i4.4)') driver_id + else + call seq_comm_init(global_comm, driver_comm, NLFileName) + cpl_inst_tag = '' + end if + + !--- set task based threading counts --- + call seq_comm_getinfo(GLOID,pethreads=pethreads_GLOID,iam=iam_GLOID) + call seq_comm_setnthreads(pethreads_GLOID) + + !--- get some general data --- + it=1 + call seq_comm_getinfo(GLOID,mpicom=mpicom_GLOID,& + iamroot=iamroot_GLOID,nthreads=nthreads_GLOID) + if (iamroot_GLOID) output_perf = .true. + + call seq_comm_getinfo(CPLID,mpicom=mpicom_CPLID,& + iamroot=iamroot_CPLID,nthreads=nthreads_CPLID,& + iam=comp_comm_iam(it)) + if (iamroot_CPLID) output_perf = .true. + + if (iamin_CPLID) complist = trim(complist)//' cpl' + + comp_id(it) = CPLID + comp_comm(it) = mpicom_CPLID + iamin_CPLID = seq_comm_iamin(CPLID) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + + do eai = 1,num_inst_atm + it=it+1 + comp_id(it) = ATMID(eai) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(ATMID(eai), mpicom=comp_comm(it), & + nthreads=nthreads_ATMID, iam=comp_comm_iam(it)) + if (seq_comm_iamin(ATMID(eai))) then + complist = trim(complist)//' '//trim(seq_comm_name(ATMID(eai))) + endif + if (seq_comm_iamroot(ATMID(eai))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLATMID, mpicom=mpicom_CPLALLATMID) + iamin_CPLALLATMID = seq_comm_iamin(CPLALLATMID) + + do eli = 1,num_inst_lnd + it=it+1 + comp_id(it) = LNDID(eli) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(LNDID(eli), mpicom=comp_comm(it), & + nthreads=nthreads_LNDID, iam=comp_comm_iam(it)) + if (seq_comm_iamin(LNDID(eli))) then + complist = trim(complist)//' '//trim(seq_comm_name(LNDID(eli))) + endif + if (seq_comm_iamroot(LNDID(eli))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLLNDID, mpicom=mpicom_CPLALLLNDID) + iamin_CPLALLLNDID = seq_comm_iamin(CPLALLLNDID) + + do eoi = 1,num_inst_ocn + it=it+1 + comp_id(it) = OCNID(eoi) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(OCNID(eoi), mpicom=comp_comm(it), & + nthreads=nthreads_OCNID, iam=comp_comm_iam(it)) + if (seq_comm_iamin (OCNID(eoi))) then + complist = trim(complist)//' '//trim(seq_comm_name(OCNID(eoi))) + endif + if (seq_comm_iamroot(OCNID(eoi))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLOCNID, mpicom=mpicom_CPLALLOCNID) + iamin_CPLALLOCNID = seq_comm_iamin(CPLALLOCNID) + + do eii = 1,num_inst_ice + it=it+1 + comp_id(it) = ICEID(eii) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(ICEID(eii), mpicom=comp_comm(it), & + nthreads=nthreads_ICEID, iam=comp_comm_iam(it)) + if (seq_comm_iamin (ICEID(eii))) then + complist = trim(complist)//' '//trim(seq_comm_name(ICEID(eii))) + endif + if (seq_comm_iamroot(ICEID(eii))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLICEID, mpicom=mpicom_CPLALLICEID) + iamin_CPLALLICEID = seq_comm_iamin(CPLALLICEID) + + do egi = 1,num_inst_glc + it=it+1 + comp_id(it) = GLCID(egi) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(GLCID(egi), mpicom=comp_comm(it), nthreads=nthreads_GLCID, iam=comp_comm_iam(it)) + if (seq_comm_iamin (GLCID(egi))) then + complist = trim(complist)//' '//trim(seq_comm_name(GLCID(egi))) + endif + if (seq_comm_iamroot(GLCID(egi))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLGLCID, mpicom=mpicom_CPLALLGLCID) + iamin_CPLALLGLCID = seq_comm_iamin(CPLALLGLCID) + + do eri = 1,num_inst_rof + it=it+1 + comp_id(it) = ROFID(eri) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(ROFID(eri), mpicom=comp_comm(it), & + nthreads=nthreads_ROFID, iam=comp_comm_iam(it)) + if (seq_comm_iamin(ROFID(eri))) then + complist = trim(complist)//' '//trim( seq_comm_name(ROFID(eri))) + endif + if (seq_comm_iamroot(ROFID(eri))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLROFID, mpicom=mpicom_CPLALLROFID) + iamin_CPLALLROFID = seq_comm_iamin(CPLALLROFID) + + do ewi = 1,num_inst_wav + it=it+1 + comp_id(it) = WAVID(ewi) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(WAVID(ewi), mpicom=comp_comm(it), & + nthreads=nthreads_WAVID, iam=comp_comm_iam(it)) + if (seq_comm_iamin(WAVID(ewi))) then + complist = trim(complist)//' '//trim(seq_comm_name(WAVID(ewi))) + endif + if (seq_comm_iamroot(WAVID(ewi))) output_perf = .true. + enddo + call seq_comm_getinfo(CPLALLWAVID, mpicom=mpicom_CPLALLWAVID) + iamin_CPLALLWAVID = seq_comm_iamin(CPLALLWAVID) + + do eei = 1,num_inst_esp + it=it+1 + comp_id(it) = ESPID(eei) + comp_iamin(it) = seq_comm_iamin(comp_id(it)) + comp_name(it) = seq_comm_name(comp_id(it)) + call seq_comm_getinfo(ESPID(eei), mpicom=comp_comm(it), & + nthreads=nthreads_ESPID, iam=comp_comm_iam(it)) + if (seq_comm_iamin (ESPID(eei))) then + complist = trim(complist)//' '//trim(seq_comm_name(ESPID(eei))) + endif + enddo + ! ESP components do not use the coupler (they are 'external') + + !---------------------------------------------------------- + !| Set logging parameters both for shr code and locally + !---------------------------------------------------------- + + if (iamroot_CPLID) then + inquire(file='cpl_modelio.nml'//trim(cpl_inst_tag),exist=exists) + if (exists) then + logunit = shr_file_getUnit() + call shr_file_setIO('cpl_modelio.nml'//trim(cpl_inst_tag),logunit) + call shr_file_setLogUnit(logunit) + loglevel = 1 + call shr_file_setLogLevel(loglevel) + endif + else + loglevel = 0 + call shr_file_setLogLevel(loglevel) + endif + + !---------------------------------------------------------- + ! Log info about the environment settings + !---------------------------------------------------------- + + if (iamroot_CPLID) then +#ifdef USE_ESMF_LIB + write(logunit,'(2A)') subname,' USE_ESMF_LIB is set' +#else + write(logunit,'(2A)') subname,' USE_ESMF_LIB is NOT set, using esmf_wrf_timemgr' +#endif + write(logunit,'(2A)') subname,' MCT_INTERFACE is set' + if (num_inst_driver > 1) & + write(logunit,'(2A,I0,A)') subname,' Driver is running with',num_inst_driver,'instances' + endif + + ! + ! When using io servers (pio_async_interface=.true.) the server tasks do not return from + ! shr_pio_init2 + ! + call shr_pio_init2(comp_id,comp_name,comp_iamin,comp_comm,comp_comm_iam) + +end subroutine cime_pre_init1 + +!=============================================================================== +!******************************************************************************* +!=============================================================================== + +subroutine cime_pre_init2() + use pio, only : file_desc_t, pio_closefile, pio_file_is_open + use shr_const_mod, only: shr_const_tkfrz, shr_const_tktrip, & + shr_const_mwwv, shr_const_mwdair + use shr_wv_sat_mod, only: shr_wv_sat_set_default, shr_wv_sat_init, & + ShrWVSatTableSpec, shr_wv_sat_make_tables + + type(file_desc_t) :: pioid + integer :: maxthreads + + character(CS) :: wv_sat_scheme + real(r8) :: wv_sat_transition_start + logical :: wv_sat_use_tables + real(r8) :: wv_sat_table_spacing + character(CL) :: errstring + + type(ShrWVSatTableSpec) :: liquid_spec, ice_spec, mixed_spec + + real(r8), parameter :: epsilo = shr_const_mwwv/shr_const_mwdair + + !---------------------------------------------------------- + !| Timer initialization (has to be after mpi init) + !---------------------------------------------------------- + maxthreads = max(nthreads_GLOID,nthreads_CPLID,nthreads_ATMID, & + nthreads_LNDID,nthreads_ICEID,nthreads_OCNID,nthreads_GLCID, & + nthreads_ROFID, nthreads_WAVID, nthreads_ESPID, pethreads_GLOID ) + + call t_initf(NLFileName, LogPrint=.true., mpicom=mpicom_GLOID, & + MasterTask=iamroot_GLOID,MaxThreads=maxthreads) + + if (iamin_CPLID) then + call seq_io_cpl_init() + endif + + !---------------------------------------------------------- + !| Memory test + !---------------------------------------------------------- + +!mt call shr_mem_init(prt=.true.) + call shr_mem_init(prt=iamroot_CPLID) + + !---------------------------------------------------------- + !| Initialize infodata + !---------------------------------------------------------- + + if (len_trim(cpl_inst_tag) > 0) then + call seq_infodata_init(infodata,nlfilename, GLOID, pioid, & + cpl_tag=cpl_inst_tag) + else + call seq_infodata_init(infodata,nlfilename, GLOID, pioid) + end if + + !---------------------------------------------------------- + ! Print Model heading and copyright message + !---------------------------------------------------------- + + if (iamroot_CPLID) call seq_cime_printlogheader() + + !---------------------------------------------------------- + !| Initialize coupled fields (depends on infodata) + !---------------------------------------------------------- + + call seq_flds_set(nlfilename, GLOID, infodata) + + !---------------------------------------------------------- + !| Obtain infodata info + !---------------------------------------------------------- + + call seq_infodata_GetData(infodata, & + info_debug=info_debug) + + if (info_debug > 1 .and. iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,'(2A)') 'Status of infodata after seq_infodata_init' + call seq_infodata_print( infodata ) + write(logunit,*) ' ' + endif + + call seq_infodata_GetData(infodata , & + read_restart=read_restart , & + restart_file=rest_file , & + timing_dir=timing_dir , & + tchkpt_dir=tchkpt_dir , & + info_debug=info_debug , & + atm_present=atm_present , & + lnd_present=lnd_present , & + ice_present=ice_present , & + ocn_present=ocn_present , & + glc_present=glc_present , & + rof_present=rof_present , & + wav_present=wav_present , & + esp_present=esp_present , & + single_column=single_column , & + aqua_planet=aqua_planet , & + cpl_seq_option=cpl_seq_option , & + drv_threading=drv_threading , & + do_histinit=do_histinit , & + do_budgets=do_budgets , & + budget_inst=budget_inst , & + budget_daily=budget_daily , & + budget_month=budget_month , & + budget_ann=budget_ann , & + budget_ltann=budget_ltann , & + budget_ltend=budget_ltend , & + histaux_a2x=do_hist_a2x , & + histaux_a2x1hri=do_hist_a2x1hri , & + histaux_a2x1hr=do_hist_a2x1hr , & + histaux_a2x3hr =do_hist_a2x3hr , & + histaux_a2x3hrp=do_hist_a2x3hrp , & + histaux_a2x24hr=do_hist_a2x24hr , & + histaux_l2x=do_hist_l2x , & + histaux_l2x1yr=do_hist_l2x1yr , & + histaux_r2x=do_hist_r2x , & + run_barriers=run_barriers , & + mct_usealltoall=mct_usealltoall , & + mct_usevector=mct_usevector , & + aoflux_grid=aoflux_grid , & + vect_map=vect_map , & + atm_gnam=atm_gnam , & + lnd_gnam=lnd_gnam , & + ocn_gnam=ocn_gnam , & + ice_gnam=ice_gnam , & + rof_gnam=rof_gnam , & + glc_gnam=glc_gnam , & + wav_gnam=wav_gnam , & + tfreeze_option = tfreeze_option , & + cpl_decomp=seq_mctext_decomp , & + shr_map_dopole=shr_map_dopole , & + wall_time_limit=wall_time_limit , & + force_stop_at=force_stop_at , & + reprosum_use_ddpdd=reprosum_use_ddpdd , & + reprosum_diffmax=reprosum_diffmax , & + reprosum_recompute=reprosum_recompute, & + max_cplstep_time=max_cplstep_time) + + ! above - cpl_decomp is set to pass the cpl_decomp value to seq_mctext_decomp + ! (via a use statement) + + call shr_map_setDopole(shr_map_dopole) + + call shr_reprosum_setopts(& + repro_sum_use_ddpdd_in = reprosum_use_ddpdd, & + repro_sum_rel_diff_max_in = reprosum_diffmax, & + repro_sum_recompute_in = reprosum_recompute) + + ! Check cpl_seq_option + + if (trim(cpl_seq_option) /= 'CESM1_ORIG' .and. & + trim(cpl_seq_option) /= 'CESM1_ORIG_TIGHT' .and. & + trim(cpl_seq_option) /= 'CESM1_MOD' .and. & + trim(cpl_seq_option) /= 'CESM1_MOD_TIGHT' .and. & + trim(cpl_seq_option) /= 'RASM_OPTION1' .and. & + trim(cpl_seq_option) /= 'RASM_OPTION2' ) then + call shr_sys_abort(subname//' invalid cpl_seq_option = '//trim(cpl_seq_option)) + endif + + !---------------------------------------------------------- + !| Test Threading Setup in driver + ! happens to be valid on all pes for all IDs + !---------------------------------------------------------- + + if (drv_threading) then + if (iamroot_GLOID) write(logunit,*) ' ' + if (iamroot_GLOID) write(logunit,'(2A) ') subname,' Test Threading in driver' + call seq_comm_setnthreads(nthreads_GLOID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_GLOID = ',& + nthreads_GLOID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_CPLID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_CPLID = ',& + nthreads_CPLID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_ATMID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_ATMID = ',& + nthreads_ATMID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_LNDID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_LNDID = ',& + nthreads_LNDID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_OCNID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_OCNID = ',& + nthreads_OCNID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_ICEID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_ICEID = ',& + nthreads_ICEID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_GLCID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_GLCID = ',& + nthreads_GLCID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_ROFID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_ROFID = ',& + nthreads_ROFID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_WAVID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_WAVID = ',& + nthreads_WAVID,seq_comm_getnthreads() + call seq_comm_setnthreads(nthreads_ESPID) + if (iamroot_GLOID) write(logunit,'(2A,2I4)') subname,' nthreads_ESPID = ',& + nthreads_ESPID,seq_comm_getnthreads() + if (iamroot_GLOID) write(logunit,*) ' ' + + call seq_comm_setnthreads(nthreads_GLOID) + endif + + !---------------------------------------------------------- + !| Initialize time manager + !---------------------------------------------------------- + + call seq_timemgr_clockInit(seq_SyncClock, nlfilename, & + read_restart, rest_file, pioid, mpicom_gloid, & + EClock_d, EClock_a, EClock_l, EClock_o, & + EClock_i, Eclock_g, Eclock_r, Eclock_w, Eclock_e) + + if (iamroot_CPLID) then + call seq_timemgr_clockPrint(seq_SyncClock) + endif + + !---------------------------------------------------------- + !| Initialize infodata items which need the clocks + !---------------------------------------------------------- + call seq_infodata_init2(infodata, GLOID) + + call seq_infodata_getData(infodata, & + orb_iyear=orb_iyear, & + orb_iyear_align=orb_iyear_align, & + orb_mode=orb_mode) + + !---------------------------------------------------------- + ! Initialize freezing point calculation for all components + !---------------------------------------------------------- + + call shr_frz_freezetemp_init(tfreeze_option) + + if (trim(orb_mode) == trim(seq_infodata_orb_variable_year)) then + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=ymd) + + call shr_cal_date2ymd(ymd,year,month,day) + orb_cyear = orb_iyear + (year - orb_iyear_align) + + call shr_orb_params(orb_cyear, orb_eccen, orb_obliq, orb_mvelp, & + orb_obliqr, orb_lambm0, orb_mvelpp, iamroot_CPLID) + + call seq_infodata_putData(infodata, & + orb_eccen=orb_eccen, & + orb_obliqr=orb_obliqr, & + orb_lambm0=orb_lambm0, & + orb_mvelpp=orb_mvelpp) + endif + + call seq_infodata_getData(infodata, & + wv_sat_scheme=wv_sat_scheme, & + wv_sat_transition_start=wv_sat_transition_start, & + wv_sat_use_tables=wv_sat_use_tables, & + wv_sat_table_spacing=wv_sat_table_spacing) + + if (.not. shr_wv_sat_set_default(wv_sat_scheme)) then + call shr_sys_abort('Invalid wv_sat_scheme.') + end if + + call shr_wv_sat_init(shr_const_tkfrz, shr_const_tktrip, & + wv_sat_transition_start, epsilo, errstring) + + if (errstring /= "") then + call shr_sys_abort('shr_wv_sat_init: '//trim(errstring)) + end if + + ! The below produces internal lookup tables in the range 175-374K for + ! liquid water, and 125-274K for ice, with a resolution set by the + ! option wv_sat_table_spacing. + ! In theory these ranges could be specified in the namelist, but in + ! practice users will want to change them *very* rarely if ever, which + ! is why only the spacing is in the namelist. + if (wv_sat_use_tables) then + liquid_spec = ShrWVSatTableSpec(ceiling(200._r8/wv_sat_table_spacing), & + 175._r8, wv_sat_table_spacing) + ice_spec = ShrWVSatTableSpec(ceiling(150._r8/wv_sat_table_spacing), & + 125._r8, wv_sat_table_spacing) + mixed_spec = ShrWVSatTableSpec(ceiling(250._r8/wv_sat_table_spacing), & + 125._r8, wv_sat_table_spacing) + call shr_wv_sat_make_tables(liquid_spec, ice_spec, mixed_spec) + end if + + call seq_infodata_putData(infodata, & + atm_phase=1, & + lnd_phase=1, & + ocn_phase=1, & + ice_phase=1, & + glc_phase=1, & + wav_phase=1, & + esp_phase=1) + + !---------------------------------------------------------- + !| Set aqua_planet and single_column flags + ! If in single column mode, overwrite flags according to focndomain file + ! in ocn_in namelist. SCAM can reset the "present" flags for lnd, + ! ocn, ice, rof, and flood. + !---------------------------------------------------------- + + if (.not.aqua_planet .and. single_column) then + call seq_infodata_getData( infodata, & + scmlon=scmlon, scmlat=scmlat) + + call seq_comm_getinfo(OCNID(ens1), mpicom=mpicom_OCNID) + + call shr_scam_checkSurface(scmlon, scmlat, & + OCNID(ens1), mpicom_OCNID, & + lnd_present=lnd_present, & + ocn_present=ocn_present, & + ice_present=ice_present, & + rof_present=rof_present, & + flood_present=flood_present, & + rofice_present=rofice_present) + + call seq_infodata_putData(infodata, & + lnd_present=lnd_present, & + ocn_present=ocn_present, & + ice_present=ice_present, & + rof_present=rof_present, & + flood_present=flood_present, & + rofice_present=rofice_present) + endif + if(PIO_FILE_IS_OPEN(pioid)) then + call pio_closefile(pioid) + endif + +end subroutine cime_pre_init2 + +!=============================================================================== +!******************************************************************************* +!=============================================================================== + +subroutine cime_init() + + 101 format( A, 2i8, 12A, A, F8.2, A, F8.2 ) + 102 format( A, 2i8, A, 8L3 ) + 103 format( 5A ) + 104 format( A, 2i8) + 105 format( A, 2i8, A, f10.2, A, f10.2, A, A, i5, A, A) + 106 format( A, f23.12) + + !----------------------------------------------------------------------------- + !| Component Initialization + ! Note that within each component initialization, the relevant x_present flag + ! part of CIMEInit can be modified + ! By default, all these flags are set to true + ! The atm can reset the lnd_present, ice_present and ocn_present flags based + ! on aqua_planet, ideal_phys and adiabatic modes + ! The stub components will reset the present flags to false, all other + ! components will set them to true for the purposes of symmetry + !----------------------------------------------------------------------------- + + call t_startf('CPL:cime_init') + call t_adj_detailf(+1) + + call t_startf('CPL:init_comps') + if (iamroot_CPLID )then + write(logunit,*) ' ' + write(logunit,F00) 'Initialize each component: atm, lnd, rof, ocn, ice, glc, wav, esp' + call shr_sys_flush(logunit) + endif + + call t_startf('CPL:comp_init_pre_all') + call component_init_pre(atm, ATMID, CPLATMID, CPLALLATMID, infodata, ntype='atm') + call component_init_pre(lnd, LNDID, CPLLNDID, CPLALLLNDID, infodata, ntype='lnd') + call component_init_pre(rof, ROFID, CPLROFID, CPLALLROFID, infodata, ntype='rof') + call component_init_pre(ocn, OCNID, CPLOCNID, CPLALLOCNID, infodata, ntype='ocn') + call component_init_pre(ice, ICEID, CPLICEID, CPLALLICEID, infodata, ntype='ice') + call component_init_pre(glc, GLCID, CPLGLCID, CPLALLGLCID, infodata, ntype='glc') + call component_init_pre(wav, WAVID, CPLWAVID, CPLALLWAVID, infodata, ntype='wav') + call component_init_pre(esp, ESPID, CPLESPID, CPLALLESPID, infodata, ntype='esp') + call t_stopf('CPL:comp_init_pre_all') + + call t_startf('CPL:comp_init_cc_atm') + call t_adj_detailf(+2) + + call component_init_cc(Eclock_a, atm, atm_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_atm') + + call t_startf('CPL:comp_init_cc_lnd') + call t_adj_detailf(+2) + call component_init_cc(Eclock_l, lnd, lnd_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_lnd') + + call t_startf('CPL:comp_init_cc_rof') + call t_adj_detailf(+2) + call component_init_cc(Eclock_r, rof, rof_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_rof') + + call t_startf('CPL:comp_init_cc_ocn') + call t_adj_detailf(+2) + call component_init_cc(Eclock_o, ocn, ocn_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_ocn') + + call t_startf('CPL:comp_init_cc_ice') + call t_adj_detailf(+2) + call component_init_cc(Eclock_i, ice, ice_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_ice') + + call t_startf('CPL:comp_init_cc_glc') + call t_adj_detailf(+2) + call component_init_cc(Eclock_g, glc, glc_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_glc') + + call t_startf('CPL:comp_init_cc_wav') + call t_adj_detailf(+2) + call component_init_cc(Eclock_w, wav, wav_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_wav') + + call t_startf('CPL:comp_init_cc_esp') + call t_adj_detailf(+2) + call component_init_cc(Eclock_e, esp, esp_init, infodata, NLFilename) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_esp') + + call t_startf('CPL:comp_init_cx_all') + call t_adj_detailf(+2) + call component_init_cx(atm, infodata) + call component_init_cx(lnd, infodata) + call component_init_cx(rof, infodata) + call component_init_cx(ocn, infodata) + call component_init_cx(ice, infodata) + call component_init_cx(glc, infodata) + call component_init_cx(wav, infodata) + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cx_all') + + ! Determine complist (list of comps for each id) + + call t_startf('CPL:comp_list_all') + call t_adj_detailf(+2) + complist = " " + if (iamin_CPLID) complist = trim(complist)//' cpl' + + do eai = 1,num_inst_atm + iamin_ID = component_get_iamin_compid(atm(eai)) + if (iamin_ID) then + compname = component_get_name(atm(eai)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + do eli = 1,num_inst_lnd + iamin_ID = component_get_iamin_compid(lnd(eli)) + if (iamin_ID) then + compname = component_get_name(lnd(eli)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + do eii = 1,num_inst_ice + iamin_ID = component_get_iamin_compid(ice(eii)) + if (iamin_ID) then + compname = component_get_name(ice(eii)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + do eoi = 1,num_inst_ocn + iamin_ID = component_get_iamin_compid(ocn(eoi)) + if (iamin_ID) then + compname = component_get_name(ocn(eoi)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + do egi = 1,num_inst_glc + iamin_ID = component_get_iamin_compid(glc(egi)) + if (iamin_ID) then + compname = component_get_name(glc(egi)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + do ewi = 1,num_inst_wav + iamin_ID = component_get_iamin_compid(wav(ewi)) + if (iamin_ID) then + compname = component_get_name(wav(ewi)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + + do eei = 1,num_inst_esp + iamin_ID = component_get_iamin_compid(esp(eei)) + if (iamin_ID) then + compname = component_get_name(esp(eei)) + complist = trim(complist)//' '//trim(compname) + endif + enddo + + call t_adj_detailf(-2) + call t_stopf('CPL:comp_list_all') + + call t_stopf('CPL:init_comps') + !---------------------------------------------------------- + !| Determine coupling interactions based on present and prognostic flags + !---------------------------------------------------------- + + if (iamin_CPLALLATMID) call seq_infodata_exchange(infodata,CPLALLATMID,'cpl2atm_init') + if (iamin_CPLALLLNDID) call seq_infodata_exchange(infodata,CPLALLLNDID,'cpl2lnd_init') + if (iamin_CPLALLOCNID) call seq_infodata_exchange(infodata,CPLALLOCNID,'cpl2ocn_init') + if (iamin_CPLALLICEID) call seq_infodata_exchange(infodata,CPLALLICEID,'cpl2ice_init') + if (iamin_CPLALLGLCID) call seq_infodata_exchange(infodata,CPLALLGLCID,'cpl2glc_init') + if (iamin_CPLALLROFID) call seq_infodata_exchange(infodata,CPLALLROFID,'cpl2rof_init') + if (iamin_CPLALLWAVID) call seq_infodata_exchange(infodata,CPLALLWAVID,'cpl2wav_init') + + if (iamroot_CPLID) then + write(logunit,F00) 'Determine final settings for presence of surface components' + call shr_sys_flush(logunit) + endif + + call seq_infodata_getData(infodata, & + atm_present=atm_present, & + lnd_present=lnd_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + glclnd_present=glclnd_present, & + glcocn_present=glcocn_present, & + glcice_present=glcice_present, & + rof_present=rof_present, & + rofice_present=rofice_present, & + wav_present=wav_present, & + esp_present=esp_present, & + flood_present=flood_present, & + atm_prognostic=atm_prognostic, & + lnd_prognostic=lnd_prognostic, & + ice_prognostic=ice_prognostic, & + iceberg_prognostic=iceberg_prognostic, & + ocn_prognostic=ocn_prognostic, & + ocnrof_prognostic=ocnrof_prognostic, & + glc_prognostic=glc_prognostic, & + rof_prognostic=rof_prognostic, & + wav_prognostic=wav_prognostic, & + esp_prognostic=esp_prognostic, & + dead_comps=dead_comps, & + esmf_map_flag=esmf_map_flag, & + atm_nx=atm_nx, atm_ny=atm_ny, & + lnd_nx=lnd_nx, lnd_ny=lnd_ny, & + rof_nx=rof_nx, rof_ny=rof_ny, & + ice_nx=ice_nx, ice_ny=ice_ny, & + glc_nx=glc_nx, glc_ny=glc_ny, & + ocn_nx=ocn_nx, ocn_ny=ocn_ny, & + wav_nx=wav_nx, wav_ny=wav_ny, & + atm_aero=atm_aero ) + + ! derive samegrid flags + + samegrid_ao = .true. + samegrid_al = .true. + samegrid_lr = .true. + samegrid_oi = .true. + samegrid_ro = .true. + samegrid_aw = .true. + samegrid_ow = .true. + samegrid_lg = .true. + samegrid_og = .true. + samegrid_ig = .true. + samegrid_alo = .true. + + ! set samegrid to true for single column + if (.not. single_column) then + if (trim(atm_gnam) /= trim(ocn_gnam)) samegrid_ao = .false. + if (trim(atm_gnam) /= trim(lnd_gnam)) samegrid_al = .false. + if (trim(lnd_gnam) /= trim(rof_gnam)) samegrid_lr = .false. + if (trim(rof_gnam) /= trim(ocn_gnam)) samegrid_ro = .false. + if (trim(ocn_gnam) /= trim(ice_gnam)) samegrid_oi = .false. + if (trim(atm_gnam) /= trim(wav_gnam)) samegrid_aw = .false. + if (trim(ocn_gnam) /= trim(wav_gnam)) samegrid_ow = .false. + if (trim(lnd_gnam) /= trim(glc_gnam)) samegrid_lg = .false. + if (trim(ocn_gnam) /= trim(glc_gnam)) samegrid_og = .false. + if (trim(ice_gnam) /= trim(glc_gnam)) samegrid_ig = .false. + samegrid_alo = (samegrid_al .and. samegrid_ao) + endif + + ! derive coupling connection flags + + atm_c2_lnd = .false. + atm_c2_ocn = .false. + atm_c2_ice = .false. + atm_c2_wav = .false. + lnd_c2_atm = .false. + lnd_c2_rof = .false. + lnd_c2_glc = .false. + ocn_c2_atm = .false. + ocn_c2_ice = .false. + ocn_c2_wav = .false. + ice_c2_atm = .false. + ice_c2_ocn = .false. + ice_c2_wav = .false. + rof_c2_lnd = .false. + rof_c2_ocn = .false. + rof_c2_ice = .false. + glc_c2_lnd = .false. + glc_c2_ocn = .false. + glc_c2_ice = .false. + wav_c2_ocn = .false. + + if (atm_present) then + if (lnd_prognostic) atm_c2_lnd = .true. + if (ocn_prognostic) atm_c2_ocn = .true. + if (ocn_present ) atm_c2_ocn = .true. ! needed for aoflux calc if aoflux=ocn + if (ice_prognostic) atm_c2_ice = .true. + if (wav_prognostic) atm_c2_wav = .true. + endif + if (lnd_present) then + if (atm_prognostic) lnd_c2_atm = .true. + if (rof_prognostic) lnd_c2_rof = .true. + if (glc_prognostic) lnd_c2_glc = .true. + endif + if (ocn_present) then + if (atm_prognostic) ocn_c2_atm = .true. + if (atm_present ) ocn_c2_atm = .true. ! needed for aoflux calc if aoflux=atm + if (ice_prognostic) ocn_c2_ice = .true. + if (wav_prognostic) ocn_c2_wav = .true. + endif + if (ice_present) then + if (atm_prognostic) ice_c2_atm = .true. + if (ocn_prognostic) ice_c2_ocn = .true. + if (wav_prognostic) ice_c2_wav = .true. + endif + if (rof_present) then + if (lnd_prognostic ) rof_c2_lnd = .true. + if (ocnrof_prognostic) rof_c2_ocn = .true. + if (rofice_present .and. iceberg_prognostic) rof_c2_ice = .true. + endif + if (glc_present) then + if (glclnd_present .and. lnd_prognostic) glc_c2_lnd = .true. + if (glcocn_present .and. ocn_prognostic) glc_c2_ocn = .true. + if (glcice_present .and. iceberg_prognostic) glc_c2_ice = .true. + endif + if (wav_present) then + if (ocn_prognostic) wav_c2_ocn = .true. + endif + + !---------------------------------------------------------- + ! Set domain check and other flag + !---------------------------------------------------------- + + domain_check = .true. + if (single_column ) domain_check = .false. + if (dead_comps ) domain_check = .false. + + ! set skip_ocean_run flag, used primarily for ocn run on first timestep + ! use reading a restart as a surrogate from whether this is a startup run + + skip_ocean_run = .true. + if ( read_restart) skip_ocean_run = .false. + ocnrun_count = 0 + cpl2ocn_first = .true. + + do_histavg = .true. + if (seq_timemgr_histavg_type == seq_timemgr_type_never) then + do_histavg = .false. + endif + + !---------------------------------------------------------- + !| Write component and coupler setup information + !---------------------------------------------------------- + + if (iamroot_CPLID) then + write(logunit,* )' ' + write(logunit,F00)'After component initialization:' + write(logunit,F0L)'atm model present = ',atm_present + write(logunit,F0L)'lnd model present = ',lnd_present + write(logunit,F0L)'ocn model present = ',ocn_present + write(logunit,F0L)'ice model present = ',ice_present + write(logunit,F0L)'glc model present = ',glc_present + write(logunit,F0L)'glc/lnd present = ',glclnd_present + write(logunit,F0L)'glc/ocn present = ',glcocn_present + write(logunit,F0L)'glc/ice present = ',glcice_present + write(logunit,F0L)'rof model present = ',rof_present + write(logunit,F0L)'rof/ice present = ',rofice_present + write(logunit,F0L)'rof/flood present = ',flood_present + write(logunit,F0L)'wav model present = ',wav_present + write(logunit,F0L)'esp model present = ',esp_present + + write(logunit,F0L)'atm model prognostic = ',atm_prognostic + write(logunit,F0L)'lnd model prognostic = ',lnd_prognostic + write(logunit,F0L)'ocn model prognostic = ',ocn_prognostic + write(logunit,F0L)'ice model prognostic = ',ice_prognostic + write(logunit,F0L)'iceberg prognostic = ',iceberg_prognostic + write(logunit,F0L)'glc model prognostic = ',glc_prognostic + write(logunit,F0L)'rof model prognostic = ',rof_prognostic + write(logunit,F0L)'ocn rof prognostic = ',ocnrof_prognostic + write(logunit,F0L)'wav model prognostic = ',wav_prognostic + write(logunit,F0L)'esp model prognostic = ',esp_prognostic + + write(logunit,F0L)'atm_c2_lnd = ',atm_c2_lnd + write(logunit,F0L)'atm_c2_ocn = ',atm_c2_ocn + write(logunit,F0L)'atm_c2_ice = ',atm_c2_ice + write(logunit,F0L)'atm_c2_wav = ',atm_c2_wav + write(logunit,F0L)'lnd_c2_atm = ',lnd_c2_atm + write(logunit,F0L)'lnd_c2_rof = ',lnd_c2_rof + write(logunit,F0L)'lnd_c2_glc = ',lnd_c2_glc + write(logunit,F0L)'ocn_c2_atm = ',ocn_c2_atm + write(logunit,F0L)'ocn_c2_ice = ',ocn_c2_ice + write(logunit,F0L)'ocn_c2_wav = ',ocn_c2_wav + write(logunit,F0L)'ice_c2_atm = ',ice_c2_atm + write(logunit,F0L)'ice_c2_ocn = ',ice_c2_ocn + write(logunit,F0L)'ice_c2_wav = ',ice_c2_wav + write(logunit,F0L)'rof_c2_lnd = ',rof_c2_lnd + write(logunit,F0L)'rof_c2_ocn = ',rof_c2_ocn + write(logunit,F0L)'rof_c2_ice = ',rof_c2_ice + write(logunit,F0L)'glc_c2_lnd = ',glc_c2_lnd + write(logunit,F0L)'glc_c2_ocn = ',glc_c2_ocn + write(logunit,F0L)'glc_c2_ice = ',glc_c2_ice + write(logunit,F0L)'wav_c2_ocn = ',wav_c2_ocn + + write(logunit,F0L)'dead components = ',dead_comps + write(logunit,F0L)'domain_check = ',domain_check + write(logunit,F01)'atm_nx,atm_ny = ',atm_nx,atm_ny,trim(atm_gnam) + write(logunit,F01)'lnd_nx,lnd_ny = ',lnd_nx,lnd_ny,trim(lnd_gnam) + write(logunit,F01)'rof_nx,rof_ny = ',rof_nx,rof_ny,trim(rof_gnam) + write(logunit,F01)'ice_nx,ice_ny = ',ice_nx,ice_ny,trim(ice_gnam) + write(logunit,F01)'ocn_nx,ocn_ny = ',ocn_nx,ocn_ny,trim(ocn_gnam) + write(logunit,F01)'glc_nx,glc_ny = ',glc_nx,glc_ny,trim(glc_gnam) + write(logunit,F01)'wav_nx,wav_ny = ',wav_nx,wav_ny,trim(wav_gnam) + write(logunit,F0L)'samegrid_ao = ',samegrid_ao + write(logunit,F0L)'samegrid_al = ',samegrid_al + write(logunit,F0L)'samegrid_ro = ',samegrid_ro + write(logunit,F0L)'samegrid_aw = ',samegrid_aw + write(logunit,F0L)'samegrid_ow = ',samegrid_ow + write(logunit,F0L)'skip init ocean run = ',skip_ocean_run + write(logunit,F00)'cpl sequence option = ',trim(cpl_seq_option) + write(logunit,F0L)'do_histavg = ',do_histavg + write(logunit,F0L)'atm_aero = ',atm_aero + write(logunit,* )' ' + call shr_sys_flush(logunit) + endif + + !---------------------------------------------------------- + !| Present and prognostic consistency checks + !---------------------------------------------------------- + + if (atm_prognostic .and. .not.atm_present) then + call shr_sys_abort(subname//' ERROR: if prognostic atm must also have atm present') + endif + if (ocn_prognostic .and. .not.ocn_present) then + call shr_sys_abort(subname//' ERROR: if prognostic ocn must also have ocn present') + endif + if (lnd_prognostic .and. .not.lnd_present) then + call shr_sys_abort(subname//' ERROR: if prognostic lnd must also have lnd present') + endif + if (ice_prognostic .and. .not.ice_present) then + call shr_sys_abort(subname//' ERROR: if prognostic ice must also have ice present') + endif + if (iceberg_prognostic .and. .not.ice_prognostic) then + call shr_sys_abort(subname//' ERROR: if prognostic iceberg must also have ice prognostic') + endif + if (glc_prognostic .and. .not.glc_present) then + call shr_sys_abort(subname//' ERROR: if prognostic glc must also have glc present') + endif + if (rof_prognostic .and. .not.rof_present) then + call shr_sys_abort(subname//' ERROR: if prognostic rof must also have rof present') + endif + if (wav_prognostic .and. .not.wav_present) then + call shr_sys_abort(subname//' ERROR: if prognostic wav must also have wav present') + endif + if (esp_prognostic .and. .not.esp_present) then + call shr_sys_abort(subname//' ERROR: if prognostic esp must also have esp present') + endif +#ifndef CPL_BYPASS + if ((ice_prognostic .or. ocn_prognostic .or. lnd_prognostic) .and. .not. atm_present) then + call shr_sys_abort(subname//' ERROR: if prognostic surface model must also have atm present') + endif +#endif + if ((glclnd_present .or. glcocn_present .or. glcice_present) .and. .not.glc_present) then + call shr_sys_abort(subname//' ERROR: if glcxxx present must also have glc present') + endif + if (rofice_present .and. .not.rof_present) then + call shr_sys_abort(subname//' ERROR: if rofice present must also have rof present') + endif + if (ocnrof_prognostic .and. .not.rof_present) then + if (iamroot_CPLID) then + write(logunit,F00) 'WARNING: ocnrof_prognostic is TRUE but rof_present is FALSE' + call shr_sys_flush(logunit) + endif + endif + + !---------------------------------------------------------- + !| Samegrid checks + !---------------------------------------------------------- + + if (.not. samegrid_oi) then + call shr_sys_abort(subname//' ERROR: samegrid_oi is false') + endif + + !---------------------------------------------------------- + !| Check instances of prognostic components + !---------------------------------------------------------- + + if (atm_prognostic .and. num_inst_atm /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: atm_prognostic but num_inst_atm not num_inst_max') + if (lnd_prognostic .and. num_inst_lnd /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: lnd_prognostic but num_inst_lnd not num_inst_max') + if (ocn_prognostic .and. (num_inst_ocn /= num_inst_max .and. num_inst_ocn /= 1)) & + call shr_sys_abort(subname//' ERROR: ocn_prognostic but num_inst_ocn not 1 or num_inst_max') + if (ice_prognostic .and. num_inst_ice /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: ice_prognostic but num_inst_ice not num_inst_max') + if (glc_prognostic .and. num_inst_glc /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: glc_prognostic but num_inst_glc not num_inst_max') + if (rof_prognostic .and. num_inst_rof /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: rof_prognostic but num_inst_rof not num_inst_max') + if (wav_prognostic .and. num_inst_wav /= num_inst_max) & + call shr_sys_abort(subname//' ERROR: wav_prognostic but num_inst_wav not num_inst_max') + + !---------------------------------------------------------- + !| Initialize attribute vectors for prep_c2C_init_avs routines and fractions + !| Initialize mapping between components + !---------------------------------------------------------- + + if (iamin_CPLID) then + + call t_startf('CPL:init_maps') + call t_adj_detailf(+2) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call prep_atm_init(infodata, ocn_c2_atm, ice_c2_atm, lnd_c2_atm) + + call prep_lnd_init(infodata, atm_c2_lnd, rof_c2_lnd, glc_c2_lnd) + + call prep_ocn_init(infodata, atm_c2_ocn, atm_c2_ice, ice_c2_ocn, rof_c2_ocn, wav_c2_ocn, glc_c2_ocn) + + call prep_ice_init(infodata, ocn_c2_ice, glc_c2_ice, rof_c2_ice ) + + call prep_rof_init(infodata, lnd_c2_rof) + + call prep_glc_init(infodata, lnd_c2_glc) + + call prep_wav_init(infodata, atm_c2_wav, ocn_c2_wav, ice_c2_wav) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_adj_detailf(-2) + call t_stopf('CPL:init_maps') + + endif + + !---------------------------------------------------------- + !| Update aream in domains where appropriate + !---------------------------------------------------------- + + if (iamin_CPLID) then + call t_startf ('CPL:init_aream') + call t_adj_detailf(+2) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_init_aream(infodata, rof_c2_ocn, samegrid_ao, samegrid_al, & + samegrid_ro, samegrid_lg) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_aream') + endif ! iamin_CPLID + + !---------------------------------------------------------- + !| Check domains + ! This must be done after the mappers are initialized since + ! checking is done on each processor and not with a global gather + !---------------------------------------------------------- + + if (iamin_CPLID) then + call t_startf ('CPL:init_domain_check') + call t_adj_detailf(+2) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (domain_check) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Performing domain checking' + call shr_sys_flush(logunit) + endif + + call seq_domain_check( infodata, & + atm(ens1), ice(ens1), lnd(ens1), ocn(ens1), rof(ens1), glc(ens1), & + samegrid_al, samegrid_ao, samegrid_ro, samegrid_lg) + + endif + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_domain_check') + endif ! iamin_CPLID + + !---------------------------------------------------------- + !| Initialize area corrections based on aream (read in map_init) and area + !| Area correct component initialization output fields + !| Map initial component AVs from component to coupler pes + !---------------------------------------------------------- + + areafact_samegrid = .false. +#if (defined BFB_CAM_SCAM_IOP ) + if (.not.samegrid_alo) then + call shr_sys_abort(subname//' ERROR: samegrid_alo is false - Must run with same atm/ocn/lnd grids when configured for scam iop') + else + areafact_samegrid = .true. + endif +#endif + if (single_column) areafact_samegrid = .true. + + call t_startf ('CPL:init_areacor') + call t_adj_detailf(+2) + + call mpi_barrier(mpicom_GLOID,ierr) + if (atm_present) call component_init_areacor(atm, areafact_samegrid, seq_flds_a2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (lnd_present) call component_init_areacor(lnd, areafact_samegrid, seq_flds_l2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (rof_present) call component_init_areacor(rof, areafact_samegrid, seq_flds_r2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (ocn_present) call component_init_areacor(ocn, areafact_samegrid, seq_flds_o2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (ice_present) call component_init_areacor(ice, areafact_samegrid, seq_flds_i2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (glc_present) call component_init_areacor(glc, areafact_samegrid, seq_flds_g2x_fluxes) + + call mpi_barrier(mpicom_GLOID,ierr) + if (wav_present) call component_init_areacor(wav, areafact_samegrid, seq_flds_w2x_fluxes) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_areacor') + + !---------------------------------------------------------- + !| global sum diagnostics for IC data + !---------------------------------------------------------- + + if (iamin_CPLID .and. info_debug > 1) then + call t_startf ('CPL:init_diag') + call t_adj_detailf(+2) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (atm_present) then + call component_diag(infodata, atm, flow='c2x', comment='recv IC atm', & + info_debug=info_debug) + endif + if (ice_present) then + call component_diag(infodata, ice, flow='c2x', comment='recv IC ice', & + info_debug=info_debug) + endif + if (lnd_present) then + call component_diag(infodata, lnd, flow='c2x', comment='recv IC lnd', & + info_debug=info_debug) + endif + if (rof_present) then + call component_diag(infodata, rof, flow='c2x', comment='recv IC rof', & + info_debug=info_debug) + endif + if (ocn_present) then + call component_diag(infodata, ocn, flow='c2x', comment='recv IC ocn', & + info_debug=info_debug) + endif + if (glc_present) then + call component_diag(infodata, glc, flow='c2x', comment='recv IC glc', & + info_debug=info_debug) + endif + if (wav_present) then + call component_diag(infodata, wav, flow='c2x', comment='recv IC wav', & + info_debug=info_debug) + endif + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_diag') + endif + + !---------------------------------------------------------- + !| Initialize fractions + !---------------------------------------------------------- + + if (iamin_CPLID) then + call t_startf ('CPL:init_fracs') + call t_adj_detailf(+2) + + allocate(fractions_ax(num_inst_frc)) + allocate(fractions_lx(num_inst_frc)) + allocate(fractions_ox(num_inst_frc)) + allocate(fractions_ix(num_inst_frc)) + allocate(fractions_gx(num_inst_frc)) + allocate(fractions_rx(num_inst_frc)) + allocate(fractions_wx(num_inst_frc)) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + do efi = 1,num_inst_frc + eii = mod((efi-1),num_inst_ice) + 1 + + if (iamroot_CPLID) then + write(logunit,*) ' ' + if (efi == 1) write(logunit,F00) 'Initializing fractions' + endif + + call seq_frac_init(infodata, & + atm(ens1), ice(ens1), lnd(ens1), & + ocn(ens1), glc(ens1), rof(ens1), & + wav(ens1), & + fractions_ax(efi), fractions_ix(efi), fractions_lx(efi), & + fractions_ox(efi), fractions_gx(efi), fractions_rx(efi), & + fractions_wx(efi)) + + if (iamroot_CPLID) then + write(logunit,*) ' ' + if (efi == 1) write(logunit,F00) 'Setting fractions' + endif + + call seq_frac_set(infodata, ice(eii), & + fractions_ax(efi), fractions_ix(efi), fractions_ox(efi)) + + enddo + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_fracs') + endif + + !---------------------------------------------------------- + !| Initialize prep_aoflux_mod module variables + !---------------------------------------------------------- + + if (iamin_CPLID) then + call prep_aoflux_init(infodata, fractions_ox, fractions_ax) + endif + + !---------------------------------------------------------- + !| Initialize atm/ocn flux component and compute ocean albedos + !---------------------------------------------------------- + + if (iamin_CPLID) then + if (ocn_present) then + call t_startf ('CPL:init_aoflux') + call t_adj_detailf(+2) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing atm/ocn flux component' + endif + + if (trim(aoflux_grid) == 'ocn') then + + call seq_flux_init_mct(ocn(ens1), fractions_ox(ens1)) + + elseif (trim(aoflux_grid) == 'atm') then + + call seq_flux_init_mct(atm(ens1), fractions_ax(ens1)) + + elseif (trim(aoflux_grid) == 'exch') then + + call shr_sys_abort(subname//' aoflux_grid = exch not validated') + call seq_flux_initexch_mct(atm(ens1), ocn(ens1), mpicom_cplid, cplid) + + else + call shr_sys_abort(subname//' aoflux_grid = '//trim(aoflux_grid)//' not available') + + endif + + do exi = 1,num_inst_xao + !tcx is this correct? relation between xao and frc for ifrad and ofrad + efi = mod((exi-1),num_inst_frc) + 1 + eai = mod((exi-1),num_inst_atm) + 1 + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + a2x_ox => prep_ocn_get_a2x_ox() + call seq_flux_ocnalb_mct(infodata, ocn(1), a2x_ox(eai), fractions_ox(efi), xao_ox(exi)) + enddo + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_aoflux') + endif + endif + + !---------------------------------------------------------- + !| ATM PREP for recalculation of initial solar + ! Note that ocean albedos are ALWAYS CALCULATED on the ocean grid + ! If aoflux_grid = 'ocn' , xao_ox is input for atm/ocn fluxes and xao_ax is output + ! If aoflux_grid = 'atm' , xao_ax is input for atm/ocn fluxes and xao_ox is not used + ! If aoflux_grid = 'exch', xao_ax is input for atm/ocn /fluxes and xao_ox is not used + ! Merge atmosphere input state and run atmospheric radiation + !---------------------------------------------------------- + + if (atm_prognostic) then + if (iamin_CPLID) then + + if (lnd_present) then + ! Get lnd output on atm grid + call prep_atm_calc_l2x_ax(fractions_lx, timer='CPL:init_atminit') + endif + + if (ice_present) then + ! Get ice output on atm grid + call prep_atm_calc_i2x_ax(fractions_ix, timer='CPL:init_atminit') + endif + + if (ocn_present) then + ! Get ocn output on atm grid + call prep_atm_calc_o2x_ax(fractions_ox, timer='CPL:init_atminit') + endif + + if (ocn_present) then + ! Get albedos on atm grid + call prep_aoflux_calc_xao_ax(fractions_ox, flds='albedos', timer='CPL:init_atminit') + + ! Get atm/ocn fluxes on atm grid + if (trim(aoflux_grid) == 'ocn') then + call prep_aoflux_calc_xao_ax(fractions_ox, flds='states_and_fluxes', & + timer='CPL:init_atminit') + endif + endif + + if (lnd_present .or. ocn_present) then + ! Merge input to atmosphere on coupler pes + xao_ax => prep_aoflux_get_xao_ax() + if (associated(xao_ax)) then + call prep_atm_mrg(infodata, & + fractions_ax=fractions_ax, xao_ax=xao_ax, timer_mrg='CPL:init_atminit') + endif + endif + + call component_diag(infodata, atm, flow='x2c', comment='send atm', info_debug=info_debug) + + endif + + endif ! atm_prognostic + + !---------------------------------------------------------- + !| Second phase of atmosphere component initialization + ! Recalculate solar based on input albedo's from surface components. + ! Data or dead atmosphere may just return on this phase. + !---------------------------------------------------------- + + if (atm_present) then + call t_startf('CPL:comp_init_cc_atm2') + call t_adj_detailf(+2) + + if (iamroot_CPLID) then + write(logunit,F00) 'Calling atm_init_mct phase 2' + endif + + ! Send atm input data from coupler pes to atm pes + if (atm_prognostic) then + call component_exch(atm, flow='x2c', infodata=infodata, & + infodata_string='cpl2atm_init') + endif + + ! Set atm init phase to 2 for all atm instances on component instance pes + do eai = 1,num_inst_atm + if (component_get_iamin_compid(atm(eai))) then + call seq_infodata_putData(infodata, atm_phase=2) + endif + enddo + + ! Run atm_init_mct with init phase of 2 + call component_init_cc(Eclock_a, atm, atm_init, & + infodata, NLFilename, & + seq_flds_x2c_fluxes=seq_flds_x2a_fluxes, & + seq_flds_c2x_fluxes=seq_flds_a2x_fluxes) + + ! Map atm output data from atm pes to cpl pes + call component_exch(atm, flow='c2x', infodata=infodata, & + infodata_string='atm2cpl_init') + + if (iamin_CPLID) then + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + call component_diag(infodata, atm, flow='c2x', comment= 'recv IC2 atm', & + info_debug=info_debug) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif + + call t_adj_detailf(-2) + call t_stopf('CPL:comp_init_cc_atm2') + endif ! atm present + + !---------------------------------------------------------- + !| Get time manager's index for driver + !---------------------------------------------------------- + drv_index = seq_timemgr_pause_component_index('drv') + + !---------------------------------------------------------- + !| Read driver restart file, overwrite anything previously sent or computed + !---------------------------------------------------------- + + call t_startf('CPL:init_readrestart') + call t_adj_detailf(+2) + + call seq_diag_zero_mct(mode='all') + if (read_restart .and. iamin_CPLID) then + call seq_rest_read(rest_file, infodata, & + atm, lnd, ice, ocn, rof, glc, wav, esp, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx) + endif + + call t_adj_detailf(-2) + call t_stopf ('CPL:init_readrestart') + + !---------------------------------------------------------- + !| Map initial r2x_rx and g2x_gx to _ox, _ix and _lx + !---------------------------------------------------------- + + if (iamin_CPLID ) then + if (rof_c2_ocn) then + call prep_ocn_calc_r2x_ox(timer='CPL:init_rof2ocn') + endif + if (glc_c2_ocn) then + call prep_ocn_calc_g2x_ox(timer='CPL:init_glc2ocn') + endif + if (rof_c2_ice) then + call prep_ice_calc_r2x_ix(timer='CPL:init_rof2ice') + endif + if (glc_c2_ice) then + call prep_ice_calc_g2x_ix(timer='CPL:init_glc2ice') + endif + if (rof_c2_lnd) then + call prep_lnd_calc_r2x_lx(timer='CPL:init_rof2lnd') + endif + if (glc_c2_lnd) then + call prep_lnd_calc_g2x_lx(timer='CPL:init_gllndnd') + endif + endif + + !---------------------------------------------------------- + !| Write histinit output file + !---------------------------------------------------------- + + if (do_histinit) then + if (iamin_CPLID) then + call t_startf('CPL:init_histinit') + call t_adj_detailf(+2) + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (iamroot_CPLID) then + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=ymd, curr_tod=tod ) + write(logunit,104) ' Write history file at ',ymd,tod + call shr_sys_flush(logunit) + endif + call seq_hist_write(infodata, EClock_d, & + atm, lnd, ice, ocn, rof, glc, wav, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx, trim(cpl_inst_tag)) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + call t_adj_detailf(-2) + call t_stopf('CPL:init_histinit') + endif + endif + + if (iamroot_CPLID )then + write(logunit,*) ' ' + write(logunit,F00) 'Model initialization complete ' + write(logunit,*) ' ' + call shr_sys_flush(logunit) + endif + + call t_adj_detailf(-1) + call t_stopf('CPL:cime_init') + +end subroutine cime_init + + !=============================================================================== + !******************************************************************************* + !=============================================================================== + + subroutine cime_run() + use seq_comm_mct, only: atm_layout, lnd_layout, ice_layout, glc_layout, & + rof_layout, ocn_layout, wav_layout, esp_layout + use shr_string_mod, only: shr_string_listGetIndexF + use seq_comm_mct, only: num_inst_driver + + ! gptl timer lookup variables + integer, parameter :: hashcnt=7 + integer :: hashint(hashcnt) + ! Driver pause/resume + logical :: drv_pause ! Driver writes pause restart file + character(len=CL) :: drv_resume ! Driver resets state from restart file + integer :: iamroot_ESPID + +101 format( A, 2i8, 12A, A, F8.2, A, F8.2 ) +102 format( A, 2i8, A, 8L3 ) +103 format( 5A ) +104 format( A, 2i8) +105 format( A, 2i8, A, f10.2, A, f10.2, A, A, i5, A, A) +106 format( A, f23.12) +107 format( A, 2i8, A, f12.4, A, f12.4 ) +108 format( A, f10.2, A, i8.8) +109 format( A, 2f10.3) +110 format( A, 2i8, A, 9L3 ) + + + hashint = 0 + + + call seq_infodata_putData(infodata,atm_phase=1,lnd_phase=1,ocn_phase=1,ice_phase=1) + call seq_timemgr_EClockGetData( EClock_d, stepno=begstep) + call seq_timemgr_EClockGetData( EClock_d, dtime=dtime) + call seq_timemgr_EClockGetData( EClock_d, calendar=calendar) + ncpl = 86400/dtime + cktime_acc = 0._r8 + cktime_cnt = 0 + stop_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_stop) + if (seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_datestop)) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,103) subname,' NOTE: Stopping from alarm STOP DATE' + write(logunit,*) ' ' + endif + stop_alarm = .true. + endif + force_stop = .false. + force_stop_ymd = -1 + force_stop_tod = -1 + + !|---------------------------------------------------------- + !| Beginning of driver time step loop + !|---------------------------------------------------------- + + call t_startf ('CPL:RUN_LOOP_BSTART') + call mpi_barrier(mpicom_GLOID,ierr) + call t_stopf ('CPL:RUN_LOOP_BSTART') + Time_begin = mpi_wtime() + Time_bstep = mpi_wtime() + do while ( .not. stop_alarm) + + call t_startf('CPL:RUN_LOOP', hashint(1)) + call t_startf('CPL:CLOCK_ADVANCE') + + !---------------------------------------------------------- + !| Advance Clock + ! (this is time that models should have before they return + ! to the driver). Write timestamp and run alarm status + !---------------------------------------------------------- + ! Note that the glcrun_avg_alarm just controls what is passed to glc in terms + ! of averaged fields - it does NOT control when glc is called currently - + ! glc will be called on the glcrun_alarm setting - but it might not be passed relevant + ! info if the time averaging period to accumulate information passed to glc is greater + ! than the glcrun interval + + call seq_timemgr_clockAdvance( seq_SyncClock, force_stop, force_stop_ymd, force_stop_tod) + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=ymd, curr_tod=tod ) + call shr_cal_date2ymd(ymd,year,month,day) + stop_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_stop) + atmrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_atmrun) + lndrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_lndrun) + rofrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_rofrun) + icerun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_icerun) + glcrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_glcrun) + glcrun_avg_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_glcrun_avg) + wavrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_wavrun) + esprun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_esprun) + ocnrun_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_ocnrun) + ocnnext_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_ocnnext) + restart_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_restart) + history_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_history) + histavg_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_histavg) + tprof_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_tprof) + barrier_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_barrier) + pause_alarm = seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_pause) + + ! Does the driver need to pause? + drv_pause = pause_alarm .and. seq_timemgr_pause_component_active(drv_index) + + ! Check alarm consistency + if (glcrun_avg_alarm .and. .not. glcrun_alarm) then + write(logunit,*) 'ERROR: glcrun_avg_alarm is true, but glcrun_alarm is false' + write(logunit,*) 'Make sure that NCPL_BASE_PERIOD, GLC_NCPL and GLC_AVG_PERIOD' + write(logunit,*) 'are set so that glc averaging only happens at glc coupling times.' + write(logunit,*) '(It is allowable for glc coupling to be more frequent than glc averaging,' + write(logunit,*) 'but not for glc averaging to be more frequent than glc coupling.)' + call shr_sys_abort(subname//' glcrun_avg_alarm is true, but glcrun_alarm is false') + end if + + + ! this probably belongs in seq_timemgr somewhere using proper clocks + t1hr_alarm = .false. + t2hr_alarm = .false. + t3hr_alarm = .false. + t6hr_alarm = .false. + t12hr_alarm = .false. + t24hr_alarm = .false. + t1yr_alarm = .false. + if (mod(tod, 3600) == 0) t1hr_alarm = .true. + if (mod(tod, 7200) == 0) t2hr_alarm = .true. + if (mod(tod,10800) == 0) t3hr_alarm = .true. + if (mod(tod,21600) == 0) t6hr_alarm = .true. + if (mod(tod,43200) == 0) t12hr_alarm = .true. + if (tod == 0) t24hr_alarm = .true. + if (month==1 .and. day==1 .and. tod==0) t1yr_alarm = .true. + + if (seq_timemgr_alarmIsOn(EClock_d,seq_timemgr_alarm_datestop)) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,103) subname,' NOTE: Stopping from alarm STOP DATE' + write(logunit,*) ' ' + endif + stop_alarm = .true. + endif + + ! update the orbital data as needed + if (trim(orb_mode) == trim(seq_infodata_orb_variable_year)) then + orb_nyear = orb_iyear + (year - orb_iyear_align) + if (orb_nyear /= orb_cyear) then + orb_cyear = orb_nyear + call shr_orb_params(orb_cyear, orb_eccen, orb_obliq, orb_mvelp, & + orb_obliqr, orb_lambm0, orb_mvelpp, iamroot_CPLID) + call seq_infodata_putData(infodata,orb_eccen=orb_eccen,orb_obliqr=orb_obliqr, & + orb_lambm0=orb_lambm0,orb_mvelpp=orb_mvelpp) + endif + endif + + ! override ocnrun_alarm and ocnnext_alarm for first ocn run + ! skip_ocean_run is initialized above to true if it's a startup + ! if it's not a startup, ignore all of this + ! stop the overide on the second ocnrun_alarm + + if (ocnrun_alarm) ocnrun_count = ocnrun_count + 1 + if (ocnrun_count > 1) skip_ocean_run = .false. + if (skip_ocean_run) then + ocnrun_alarm = .false. + ocnnext_alarm = .false. + endif + + if (iamroot_CPLID) then + if (loglevel > 1) then + write(logunit,102) ' Alarm_state: model date = ',ymd,tod, & + ' aliogrw run alarms = ', atmrun_alarm, lndrun_alarm, & + icerun_alarm, ocnrun_alarm, glcrun_alarm, & + rofrun_alarm, wavrun_alarm, esprun_alarm + write(logunit,102) ' Alarm_state: model date = ',ymd,tod, & + ' 1.2.3.6.12.24 run alarms = ', t1hr_alarm, t2hr_alarm, & + t3hr_alarm, t6hr_alarm, t12hr_alarm, t24hr_alarm + call shr_sys_flush(logunit) + endif + endif + + call t_stopf ('CPL:CLOCK_ADVANCE') + + !---------------------------------------------------------- + !| MAP ATM to OCN + ! Set a2x_ox as a module variable in prep_ocn_mod + ! This will be used later in the ice prep and in the + ! atm/ocn flux calculation + !---------------------------------------------------------- + + if (iamin_CPLID .and. (atm_c2_ocn .or. atm_c2_ice)) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:OCNPRE1_BARRIER') + call t_drvstartf ('CPL:OCNPRE1',cplrun=.true.,barrier=mpicom_CPLID,hashint=hashint(3)) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call prep_ocn_calc_a2x_ox(timer='CPL:ocnpre1_atm2ocn') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:OCNPRE1',cplrun=.true.,hashint=hashint(3)) + endif + + !---------------------------------------------------------- + !| ATM/OCN SETUP (rasm_option1) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'RASM_OPTION1') .and. & + iamin_CPLID .and. ocn_present) then + + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ATMOCN1_BARRIER') + call t_drvstartf ('CPL:ATMOCN1',cplrun=.true.,barrier=mpicom_CPLID,hashint=hashint(4)) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (ocn_prognostic) then + ! Map ice to ocn + if (ice_c2_ocn) call prep_ocn_calc_i2x_ox(timer='CPL:atmocnp_ice2ocn') + + ! Map wav to ocn + if (wav_c2_ocn) call prep_ocn_calc_w2x_ox(timer='CPL:atmocnp_wav2ocn') + endif + + !---------------------------------------------------------- + !| atm/ocn flux on atm grid (rasm_option1 and aoflux='atm') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'atm') then + ! compute o2x_ax for flux_atmocn, will be updated before atm merge + ! do not use fractions because fractions here are NOT consistent with fractions in atm_mrg + if (ocn_c2_atm) call prep_atm_calc_o2x_ax(timer='CPL:atmoca_ocn2atm') + + call t_drvstartf ('CPL:atmocna_fluxa',barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ax => component_get_c2x_cx(atm(eai)) + o2x_ax => prep_atm_get_o2x_ax() ! array over all instances + xao_ax => prep_aoflux_get_xao_ax() ! array over all instances + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ax, o2x_ax(eoi), xao_ax(exi)) + enddo + call t_drvstopf ('CPL:atmocna_fluxa') + + if (atm_c2_ocn) call prep_aoflux_calc_xao_ox(timer='CPL:atmocna_atm2ocn') + endif ! aoflux_grid + + !---------------------------------------------------------- + !| atm/ocn flux on ocn grid (rasm_option1 and aoflux='ocn') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'ocn') then + call t_drvstartf ('CPL:atmocnp_fluxo',barrier=mpicom_CPLID,hashint=hashint(6)) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ox => prep_ocn_get_a2x_ox() + o2x_ox => component_get_c2x_cx(ocn(eoi)) + xao_ox => prep_aoflux_get_xao_ox() + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ox(eai), o2x_ox, xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_fluxo',hashint=hashint(6)) + endif + + !---------------------------------------------------------- + !| ocn prep-merge (rasm_option1) + !---------------------------------------------------------- + + xao_ox => prep_aoflux_get_xao_ox() + call prep_ocn_mrg(infodata, fractions_ox, xao_ox=xao_ox, timer_mrg='CPL:atmocnp_mrgx2o') + + ! Accumulate ocn inputs - form partial sum of tavg ocn inputs (virtual "send" to ocn) + call prep_ocn_accum(timer='CPL:atmocnp_accum') + + !---------------------------------------------------------- + !| ocn albedos (rasm_option1) + ! (MUST BE AFTER prep_ocn_mrg for swnet to ocn to be computed properly + !---------------------------------------------------------- + + call t_drvstartf ('CPL:atmocnp_ocnalb', barrier=mpicom_CPLID,hashint=hashint(5)) + do exi = 1,num_inst_xao + efi = mod((exi-1),num_inst_frc) + 1 + eai = mod((exi-1),num_inst_atm) + 1 + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + a2x_ox => prep_ocn_get_a2x_ox() + call seq_flux_ocnalb_mct(infodata, ocn(1), a2x_ox(eai), fractions_ox(efi), xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_ocnalb',hashint=hashint(5)) + + !---------------------------------------------------------- + !| ocn budget (rasm_option1) + !---------------------------------------------------------- + + if (do_budgets) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:BUDGET0_BARRIER') + call t_drvstartf ('CPL:BUDGET0',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + call seq_diag_ocn_mct(ocn(ens1), xao_ox(1), fractions_ox(ens1), infodata, & + do_o2x=.true., do_x2o=.true., do_xao=.true.) + call t_drvstopf ('CPL:BUDGET0',cplrun=.true.,budget=.true.) + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ATMOCN1',cplrun=.true.,hashint=hashint(4)) + endif + + !---------------------------------------------------------- + !| ATM/OCN SETUP-SEND (cesm1_orig, cesm1_orig_tight, cesm1_mod, cesm1_mod_tight, or rasm_option1) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'CESM1_ORIG' .or. & + trim(cpl_seq_option) == 'CESM1_ORIG_TIGHT' .or. & + trim(cpl_seq_option) == 'CESM1_MOD' .or. & + trim(cpl_seq_option) == 'CESM1_MOD_TIGHT' .or. & + trim(cpl_seq_option) == 'RASM_OPTION1' ) .and. & + ocn_present .and. ocnrun_alarm) then + + !---------------------------------------------------- + ! "startup" wait (cesm1_orig, cesm1_mod, or rasm_option1) + !---------------------------------------------------- + + if (iamin_CPLALLOCNID) then + ! want to know the time the ocean pes waited for the cpl pes + ! at the first ocnrun_alarm, min ocean wait is wait time + ! do not use t_barrierf here since it can be "off", use mpi_barrier + do eoi = 1,num_inst_ocn + if (ocn(eoi)%iamin_compid) call t_drvstartf ('CPL:C2O_INITWAIT') + enddo + call mpi_barrier(mpicom_CPLALLOCNID,ierr) + do eoi = 1,num_inst_ocn + if (ocn(eoi)%iamin_compid) call t_drvstopf ('CPL:C2O_INITWAIT') + enddo + cpl2ocn_first = .false. + endif + + !---------------------------------------------------- + !| ocn average (cesm1_orig, cesm1_orig_tight, cesm1_mod, cesm1_mod_tight, or rasm_option1) + !---------------------------------------------------- + + if (iamin_CPLID .and. ocn_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:OCNPREP_BARRIER') + call t_drvstartf ('CPL:OCNPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + ! finish accumulating ocean inputs + ! reset the value of x2o_ox with the value in x2oacc_ox + ! (module variable in prep_ocn_mod) + call prep_ocn_accum_avg(timer_accum='CPL:ocnprep_avg') + + call component_diag(infodata, ocn, flow='x2c', comment= 'send ocn', & + info_debug=info_debug, timer_diag='CPL:ocnprep_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:OCNPREP',cplrun=.true.) + endif + + !---------------------------------------------------- + !| cpl -> ocn (cesm1_orig, cesm1_orig_tight, cesm1_mod, cesm1_mod_tight, or rasm_option1) + !---------------------------------------------------- + + if (iamin_CPLALLOCNID .and. ocn_prognostic) then + call component_exch(ocn, flow='x2c', & + infodata=infodata, infodata_string='cpl2ocn_run', & + mpicom_barrier=mpicom_CPLALLOCNID, run_barriers=run_barriers, & + timer_barrier='CPL:C2O_BARRIER', timer_comp_exch='CPL:C2O', & + timer_map_exch='CPL:c2o_ocnx2ocno', timer_infodata_exch='CPL:c2o_infoexch') + endif + + endif ! end of OCN SETUP + + !---------------------------------------------------------- + !| LND SETUP-SEND + !---------------------------------------------------------- + + if (lnd_present .and. lndrun_alarm) then + + !---------------------------------------------------- + !| lnd prep-merge + !---------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:LNDPREP_BARRIER') + call t_drvstartf ('CPL:LNDPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (atm_c2_lnd) then + call prep_lnd_calc_a2x_lx(timer='CPL:lndprep_atm2lnd') + endif + + if (lnd_prognostic) then + call prep_lnd_mrg(infodata, timer_mrg='CPL:lndprep_mrgx2l') + + call component_diag(infodata, lnd, flow='x2c', comment= 'send lnd', & + info_debug=info_debug, timer_diag='CPL:lndprep_diagav') + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:LNDPREP',cplrun=.true.) + endif + + !---------------------------------------------------- + !| cpl -> lnd + !---------------------------------------------------- + + if (iamin_CPLALLLNDID) then + call component_exch(lnd, flow='x2c', & + infodata=infodata, infodata_string='cpl2lnd_run', & + mpicom_barrier=mpicom_CPLALLLNDID, run_barriers=run_barriers, & + timer_barrier='CPL:C2L_BARRIER', timer_comp_exch='CPL:C2L', & + timer_map_exch='CPL:c2l_lndx2lndl', timer_infodata_exch='CPL:c2l_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| ICE SETUP-SEND + ! Note that for atm->ice mapping below will leverage the assumption that the + ! ice and ocn are on the same grid and that mapping of atm to ocean is + ! done already for use by atmocn flux and ice model prep + !---------------------------------------------------------- + + if (ice_present .and. icerun_alarm) then + + !---------------------------------------------------- + !| ice prep-merge + !---------------------------------------------------- + + if (iamin_CPLID .and. ice_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ICEPREP_BARRIER') + + call t_drvstartf ('CPL:ICEPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + + if (ocn_c2_ice) then + call prep_ice_calc_o2x_ix(timer='CPL:iceprep_ocn2ice') + endif + + if (atm_c2_ice) then + ! This is special to avoid remapping atm to ocn + ! Note it is constrained that different prep modules cannot + ! use or call each other + a2x_ox => prep_ocn_get_a2x_ox() ! array + call prep_ice_calc_a2x_ix(a2x_ox, timer='CPL:iceprep_atm2ice') + endif + + call prep_ice_mrg(infodata, timer_mrg='CPL:iceprep_mrgx2i') + + call component_diag(infodata, ice, flow='x2c', comment= 'send ice', & + info_debug=info_debug, timer_diag='CPL:iceprep_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ICEPREP',cplrun=.true.) + endif + + !---------------------------------------------------- + !| cpl -> ice + !---------------------------------------------------- + + if (iamin_CPLALLICEID .and. ice_prognostic) then + call component_exch(ice, flow='x2c', & + infodata=infodata, infodata_string='cpl2ice_run', & + mpicom_barrier=mpicom_CPLALLICEID, run_barriers=run_barriers, & + timer_barrier='CPL:C2I_BARRIER', timer_comp_exch='CPL:C2I', & + timer_map_exch='CPL:c2i_icex2icei', timer_infodata_exch='CPL:ice_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| WAV SETUP-SEND + !---------------------------------------------------------- + if (wav_present .and. wavrun_alarm) then + + !---------------------------------------------------------- + !| wav prep-merge + !---------------------------------------------------------- + + if (iamin_CPLID .and. wav_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:WAVPREP_BARRIER') + + call t_drvstartf ('CPL:WAVPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (atm_c2_wav) then + call prep_wav_calc_a2x_wx(timer='CPL:wavprep_atm2wav') + endif + + if (ocn_c2_wav) then + call prep_wav_calc_o2x_wx(timer='CPL:wavprep_ocn2wav') + endif + + if (ice_c2_wav) then + call prep_wav_calc_i2x_wx(timer='CPL:wavprep_ice2wav') + endif + + call prep_wav_mrg(infodata, fractions_wx, timer_mrg='CPL:wavprep_mrgx2w') + + call component_diag(infodata, wav, flow='x2c', comment= 'send wav', & + info_debug=info_debug, timer_diag='CPL:wavprep_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:WAVPREP',cplrun=.true.) + endif + + !---------------------------------------------------------- + !| cpl -> wav + !---------------------------------------------------------- + + if (iamin_CPLALLWAVID .and. wav_prognostic) then + call component_exch(wav, flow='x2c', & + infodata=infodata, infodata_string='cpl2wav_run', & + mpicom_barrier=mpicom_CPLALLWAVID, run_barriers=run_barriers, & + timer_barrier='CPL:C2W_BARRIER', timer_comp_exch='CPL:C2W', & + timer_map_exch='CPL:c2w_wavx2wavw', timer_infodata_exch='CPL:c2w_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| ROF SETUP-SEND + !---------------------------------------------------------- + + if (rof_present .and. rofrun_alarm) then + + !---------------------------------------------------- + !| rof prep-merge + !---------------------------------------------------- + + if (iamin_CPLID .and. rof_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ROFPREP_BARRIER') + + call t_drvstartf ('CPL:ROFPREP', cplrun=.true., barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call prep_rof_accum_avg(timer='CPL:rofprep_l2xavg') + + if (lnd_c2_rof) then + call prep_rof_calc_l2r_rx(fractions_lx, timer='CPL:rofprep_lnd2rof') + endif + + call prep_rof_mrg(infodata, fractions_rx, timer_mrg='CPL:rofprep_mrgx2r') + + call component_diag(infodata, rof, flow='x2c', comment= 'send rof', & + info_debug=info_debug, timer_diag='CPL:rofprep_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ROFPREP',cplrun=.true.) + endif + + !---------------------------------------------------- + !| cpl -> rof + !---------------------------------------------------- + + if (iamin_CPLALLROFID .and. rof_prognostic) then + call component_exch(rof, flow='x2c', & + infodata=infodata, infodata_string='cpl2rof_run', & + mpicom_barrier=mpicom_CPLALLLNDID, run_barriers=run_barriers, & + timer_barrier='CPL:C2R_BARRIER', timer_comp_exch='CPL:C2R', & + timer_map_exch='CPL:c2r_rofx2rofr', timer_infodata_exch='CPL:c2r_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| RUN ICE MODEL + !---------------------------------------------------------- + + if (ice_present .and. icerun_alarm) then + call component_run(Eclock_i, ice, ice_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2i_fluxes, & + seq_flds_c2x_fluxes=seq_flds_i2x_fluxes, & + comp_prognostic=ice_prognostic, comp_num=comp_num_ice, & + timer_barrier= 'CPL:ICE_RUN_BARRIER', timer_comp_run='CPL:ICE_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=ice_layout) + endif + + !---------------------------------------------------------- + !| RUN LND MODEL + !---------------------------------------------------------- + + if (lnd_present .and. lndrun_alarm) then + call component_run(Eclock_l, lnd, lnd_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2l_fluxes, & + seq_flds_c2x_fluxes=seq_flds_l2x_fluxes, & + comp_prognostic=lnd_prognostic, comp_num=comp_num_lnd, & + timer_barrier= 'CPL:LND_RUN_BARRIER', timer_comp_run='CPL:LND_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=lnd_layout) + endif + + !---------------------------------------------------------- + !| RUN ROF MODEL + !---------------------------------------------------------- + + if (rof_present .and. rofrun_alarm) then + call component_run(Eclock_r, rof, rof_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2r_fluxes, & + seq_flds_c2x_fluxes=seq_flds_r2x_fluxes, & + comp_prognostic=rof_prognostic, comp_num=comp_num_rof, & + timer_barrier= 'CPL:ROF_RUN_BARRIER', timer_comp_run='CPL:ROF_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=rof_layout) + endif + + !---------------------------------------------------------- + !| RUN WAV MODEL + !---------------------------------------------------------- + + if (wav_present .and. wavrun_alarm) then + call component_run(Eclock_w, wav, wav_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2w_fluxes, & + seq_flds_c2x_fluxes=seq_flds_w2x_fluxes, & + comp_prognostic=wav_prognostic, comp_num=comp_num_wav, & + timer_barrier= 'CPL:WAV_RUN_BARRIER', timer_comp_run='CPL:WAV_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=wav_layout) + endif + + !---------------------------------------------------------- + !| RUN OCN MODEL (cesm1_orig_tight or cesm1_mod_tight) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'CESM1_ORIG_TIGHT' .or. & + trim(cpl_seq_option) == 'CESM1_MOD_TIGHT' ) .and. & + ocn_present .and. ocnrun_alarm) then + call component_run(Eclock_o, ocn, ocn_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2o_fluxes, & + seq_flds_c2x_fluxes=seq_flds_o2x_fluxes, & + comp_prognostic=ocn_prognostic, comp_num=comp_num_ocn, & + timer_barrier= 'CPL:OCNT_RUN_BARRIER', timer_comp_run='CPL:OCNT_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=ocn_layout) + endif + + !---------------------------------------------------------- + !| OCN RECV-POST (cesm1_orig_tight or cesm1_mod_tight) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'CESM1_ORIG_TIGHT' .or. & + trim(cpl_seq_option) == 'CESM1_MOD_TIGHT' ) .and. & + ocn_present .and. ocnnext_alarm) then + + !---------------------------------------------------------- + !| ocn -> cpl (cesm1_orig_tight or cesm1_mod_tight) + !---------------------------------------------------------- + + if (iamin_CPLALLOCNID) then + call component_exch(ocn, flow='c2x', & + infodata=infodata, infodata_string='ocn2cpl_run', & + mpicom_barrier=mpicom_CPLALLOCNID, run_barriers=run_barriers, & + timer_barrier='CPL:O2CT_BARRIER', timer_comp_exch='CPL:O2CT', & + timer_map_exch='CPL:o2c_ocno2ocnx', timer_infodata_exch='CPL:o2c_infoexch') + endif + + !---------------------------------------------------------- + !| ocn post (cesm1_orig_tight or cesm1_mod_tight) + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:OCNPOSTT_BARRIER') + call t_drvstartf ('CPL:OCNPOSTT',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, ocn, flow='c2x', comment= 'recv ocn', & + info_debug=info_debug, timer_diag='CPL:ocnpost_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:OCNPOSTT',cplrun=.true.) + endif + + endif + + !---------------------------------------------------------- + !| ATM/OCN SETUP (cesm1_orig, cesm1_orig_tight, cesm1_mod or cesm1_mod_tight) + !---------------------------------------------------------- + if ((trim(cpl_seq_option) == 'CESM1_ORIG' .or. & + trim(cpl_seq_option) == 'CESM1_ORIG_TIGHT' .or. & + trim(cpl_seq_option) == 'CESM1_MOD' .or. & + trim(cpl_seq_option) == 'CESM1_MOD_TIGHT' ) .and. & + iamin_CPLID .and. ocn_present) then + + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ATMOCNP_BARRIER') + call t_drvstartf ('CPL:ATMOCNP',cplrun=.true.,barrier=mpicom_CPLID,hashint=hashint(7)) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + !---------------------------------------------------------- + !| ocn prep-merge (cesm1_orig or cesm1_orig_tight) + !---------------------------------------------------------- + + if (ocn_prognostic) then + ! Map ice to ocn + if (ice_c2_ocn) call prep_ocn_calc_i2x_ox(timer='CPL:atmocnp_ice2ocn') + + ! Map wav to ocn + if (wav_c2_ocn) call prep_ocn_calc_w2x_ox(timer='CPL:atmocnp_wav2ocn') + + if (cpl_seq_option == 'CESM1_ORIG' .or. & + cpl_seq_option == 'CESM1_ORIG_TIGHT') then + xao_ox => prep_aoflux_get_xao_ox() + call prep_ocn_mrg(infodata, fractions_ox, xao_ox=xao_ox, timer_mrg='CPL:atmocnp_mrgx2o') + + ! Accumulate ocn inputs - form partial sum of tavg ocn inputs (virtual "send" to ocn) + call prep_ocn_accum(timer='CPL:atmocnp_accum') + endif + endif + + !---------------------------------------------------------- + !| atm/ocn flux on atm grid ((cesm1_orig, cesm1_orig_tight, cesm1_mod or cesm1_mod_tight) and aoflux='atm') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'atm') then + ! compute o2x_ax for flux_atmocn, will be updated before atm merge + ! do not use fractions because fractions here are NOT consistent with fractions in atm_mrg + if (ocn_c2_atm) call prep_atm_calc_o2x_ax(timer='CPL:atmoca_ocn2atm') + + call t_drvstartf ('CPL:atmocna_fluxa',barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ax => component_get_c2x_cx(atm(eai)) + o2x_ax => prep_atm_get_o2x_ax() ! array over all instances + xao_ax => prep_aoflux_get_xao_ax() ! array over all instances + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ax, o2x_ax(eoi), xao_ax(exi)) + enddo + call t_drvstopf ('CPL:atmocna_fluxa') + + if (atm_c2_ocn) call prep_aoflux_calc_xao_ox(timer='CPL:atmocna_atm2ocn') + endif ! aoflux_grid + + !---------------------------------------------------------- + !| atm/ocn flux on ocn grid ((cesm1_orig, cesm1_orig_tight, cesm1_mod or cesm1_mod_tight) and aoflux='ocn') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'ocn') then + call t_drvstartf ('CPL:atmocnp_fluxo',barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ox => prep_ocn_get_a2x_ox() + o2x_ox => component_get_c2x_cx(ocn(eoi)) + xao_ox => prep_aoflux_get_xao_ox() + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ox(eai), o2x_ox, xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_fluxo') +! else if (trim(aoflux_grid) == 'atm') then +! !--- compute later --- +! +! else if (trim(aoflux_grid) == 'exch') then +! xao_ax => prep_aoflux_get_xao_ax() +! xao_ox => prep_aoflux_get_xao_ox() +! +! call t_drvstartf ('CPL:atmocnp_fluxe',barrier=mpicom_CPLID) +! call seq_flux_atmocnexch_mct( infodata, atm(eai), ocn(eoi), & +! fractions_ax(efi), fractions_ox(efi), xao_ax(exi), xao_ox(exi) ) +! call t_drvstopf ('CPL:atmocnp_fluxe') + endif ! aoflux_grid + + !---------------------------------------------------------- + !| ocn prep-merge (cesm1_mod or cesm1_mod_tight) + !---------------------------------------------------------- + + if (ocn_prognostic) then + if (cpl_seq_option == 'CESM1_MOD' .or. & + cpl_seq_option == 'CESM1_MOD_TIGHT') then + + xao_ox => prep_aoflux_get_xao_ox() + call prep_ocn_mrg(infodata, fractions_ox, xao_ox=xao_ox, timer_mrg='CPL:atmocnp_mrgx2o') + + ! Accumulate ocn inputs - form partial sum of tavg ocn inputs (virtual "send" to ocn) + call prep_ocn_accum(timer='CPL:atmocnp_accum') + endif + endif + + !---------------------------------------------------------- + !| ocn albedos (cesm1_orig, cesm1_orig_tight, cesm1_mod or cesm1_mod_tight) + ! (MUST BE AFTER prep_ocn_mrg for swnet to ocn to be computed properly + !---------------------------------------------------------- + + call t_drvstartf ('CPL:atmocnp_ocnalb', barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + efi = mod((exi-1),num_inst_frc) + 1 + eai = mod((exi-1),num_inst_atm) + 1 + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + a2x_ox => prep_ocn_get_a2x_ox() + call seq_flux_ocnalb_mct(infodata, ocn(1), a2x_ox(eai), fractions_ox(efi), xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_ocnalb') + + !---------------------------------------------------------- + !| ocn budget (cesm1_orig, cesm1_orig_tight, cesm1_mod or cesm1_mod_tight) + !---------------------------------------------------------- + + if (do_budgets) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:BUDGET0_BARRIER') + call t_drvstartf ('CPL:BUDGET0',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + call seq_diag_ocn_mct(ocn(ens1), xao_ox(1), fractions_ox(ens1), infodata, & + do_o2x=.true., do_x2o=.true., do_xao=.true.) + call t_drvstopf ('CPL:BUDGET0',cplrun=.true.,budget=.true.) + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ATMOCNP',cplrun=.true.,hashint=hashint(7)) + endif + + !---------------------------------------------------------- + !| LND RECV-POST + !---------------------------------------------------------- + + if (lnd_present .and. lndrun_alarm) then + + !---------------------------------------------------------- + !| lnd -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLLNDID) then + call component_exch(lnd, flow='c2x', infodata=infodata, infodata_string='lnd2cpl_run', & + mpicom_barrier=mpicom_CPLALLLNDID, run_barriers=run_barriers, & + timer_barrier='CPL:L2C_BARRIER', timer_comp_exch='CPL:L2C', & + timer_map_exch='CPL:l2c_lndl2lndx', timer_infodata_exch='lnd2cpl_run') + endif + + !---------------------------------------------------------- + !| lnd post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:LNDPOST_BARRIER') + call t_drvstartf ('CPL:LNDPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, lnd, flow='c2x', comment='recv lnd', & + info_debug=info_debug, timer_diag='CPL:lndpost_diagav') + + ! Accumulate rof and glc inputs (module variables in prep_rof_mod and prep_glc_mod) + if (lnd_c2_rof) then + call prep_rof_accum(timer='CPL:lndpost_accl2r') + endif + if (lnd_c2_glc) then + call prep_glc_accum(timer='CPL:lndpost_accl2g' ) + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:LNDPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| GLC SETUP-SEND + !---------------------------------------------------------- + + if (glc_present .and. glcrun_alarm) then + + !---------------------------------------------------- + !| glc prep-merge + !---------------------------------------------------- + + if (iamin_CPLID .and. glc_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:GLCPREP_BARRIER') + call t_drvstartf ('CPL:GLCPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (lnd_c2_glc) then + ! NOTE - only create appropriate input to glc if the avg_alarm is on + if (glcrun_avg_alarm) then + call prep_glc_accum_avg(timer='CPL:glcprep_avg') + + ! Note that l2x_gx is obtained from mapping the module variable l2gacc_lx + call prep_glc_calc_l2x_gx(fractions_lx, timer='CPL:glcprep_lnd2glc') + + call prep_glc_mrg(infodata, fractions_gx, timer_mrg='CPL:glcprep_mrgx2g') + + call component_diag(infodata, glc, flow='x2c', comment='send glc', & + info_debug=info_debug, timer_diag='CPL:glcprep_diagav') + + else + call prep_glc_zero_fields() + end if ! glcrun_avg_alarm + end if ! lnd_c2_glc + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:GLCPREP',cplrun=.true.) + + end if ! iamin_CPLID .and. glc_prognostic + + ! Set the infodata field on all tasks (not just those with iamin_CPLID). + if (glc_prognostic) then + if (glcrun_avg_alarm) then + call seq_infodata_PutData(infodata, glc_valid_input=.true.) + else + call seq_infodata_PutData(infodata, glc_valid_input=.false.) + end if + end if + + !---------------------------------------------------- + !| cpl -> glc + !---------------------------------------------------- + + if (iamin_CPLALLGLCID .and. glc_prognostic) then + call component_exch(glc, flow='x2c', & + infodata=infodata, infodata_string='cpl2glc_run', & + mpicom_barrier=mpicom_CPLALLGLCID, run_barriers=run_barriers, & + timer_barrier='CPL:C2G_BARRIER', timer_comp_exch='CPL:C2G', & + timer_map_exch='CPL:c2g_glcx2glcg', timer_infodata_exch='CPL:c2g_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| ROF RECV-POST + !---------------------------------------------------------- + + if (rof_present .and. rofrun_alarm) then + + !---------------------------------------------------------- + !| rof -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLROFID) then + call component_exch(rof, flow='c2x', & + infodata=infodata, infodata_string='rof2cpl_run', & + mpicom_barrier=mpicom_CPLALLROFID, run_barriers=run_barriers, & + timer_barrier='CPL:R2C_BARRIER', timer_comp_exch='CPL:R2C', & + timer_map_exch='CPL:r2c_rofr2rofx', timer_infodata_exch='CPL:r2c_infoexch') + endif + + !---------------------------------------------------------- + !| rof post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ROFPOST_BARRIER') + call t_drvstartf ('CPL:ROFPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, rof, flow='c2x', comment= 'recv rof', & + info_debug=info_debug, timer_diag='CPL:rofpost_diagav') + + if (rof_c2_lnd) then + call prep_lnd_calc_r2x_lx(timer='CPL:rofpost_rof2lnd') + endif + + if (rof_c2_ice) then + call prep_ice_calc_r2x_ix(timer='CPL:rofpost_rof2ice') + endif + + if (rof_c2_ocn) then + call prep_ocn_calc_r2x_ox(timer='CPL:rofpost_rof2ocn') + endif + + call t_drvstopf ('CPL:ROFPOST', cplrun=.true.) + endif + endif + + if (rof_present) then + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='DRIVER_ROFPOST_BARRIER') + call t_drvstartf ('DRIVER_ROFPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (do_hist_r2x) then + call t_drvstartf ('driver_rofpost_histaux', barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + suffix = component_get_suffix(rof(eri)) + call seq_hist_writeaux(infodata, EClock_d, rof(eri), flow='c2x', & + aname='r2x'//trim(suffix), dname='domrb', & + nx=rof_nx, ny=rof_ny, nt=1, write_now=t24hr_alarm) + enddo + call t_drvstopf ('driver_rofpost_histaux') + endif + call t_drvstopf ('DRIVER_ROFPOST', cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| Budget with old fractions + !---------------------------------------------------------- + + ! WJS (2-17-11): I am just using the first instance for the budgets because we + ! don't expect budgets to be conserved for our case (I case). Also note that we + ! don't expect budgets to be conserved for the interactive ensemble use case either. + ! tcraig (aug 2012): put this after rof->cpl so the budget sees the new r2x_rx. + ! it will also use the current r2x_ox here which is the value from the last timestep + ! consistent with the ocean coupling + + if (iamin_CPLID .and. do_budgets) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:BUDGET1_BARRIER') + call t_drvstartf ('CPL:BUDGET1',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + if (lnd_present) then + call seq_diag_lnd_mct(lnd(ens1), fractions_lx(ens1), infodata, & + do_l2x=.true., do_x2l=.true.) + endif + if (rof_present) then + call seq_diag_rof_mct(rof(ens1), fractions_rx(ens1), infodata) + endif + if (ice_present) then + call seq_diag_ice_mct(ice(ens1), fractions_ix(ens1), infodata, & + do_x2i=.true.) + endif + call t_drvstopf ('CPL:BUDGET1',cplrun=.true.,budget=.true.) + endif + + + !---------------------------------------------------------- + !| ICE RECV-POST + !---------------------------------------------------------- + + if (ice_present .and. icerun_alarm) then + + !---------------------------------------------------------- + !| ice -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLICEID) then + call component_exch(ice, flow='c2x', & + infodata=infodata, infodata_string='ice2cpl_run', & + mpicom_barrier=mpicom_CPLALLICEID, run_barriers=run_barriers, & + timer_barrier='CPL:I2C_BARRIER', timer_comp_exch='CPL:I2C', & + timer_map_exch='CPL:i2c_icei2icex', timer_infodata_exch='CPL:i2c_infoexch') + endif + + !---------------------------------------------------------- + !| ice post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ICEPOST_BARRIER') + call t_drvstartf ('CPL:ICEPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, ice, flow='c2x', comment= 'recv ice', & + info_debug=info_debug, timer_diag='CPL:icepost_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ICEPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| Update fractions based on new ice fractions + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:FRACSET_BARRIER') + call t_drvstartf ('CPL:FRACSET',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + call t_drvstartf ('CPL:fracset_fracset',barrier=mpicom_CPLID) + + do efi = 1,num_inst_frc + eii = mod((efi-1),num_inst_ice) + 1 + + call seq_frac_set(infodata, ice(eii), & + fractions_ax(efi), fractions_ix(efi), fractions_ox(efi)) + enddo + call t_drvstopf ('CPL:fracset_fracset') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:FRACSET',cplrun=.true.) + endif + + !---------------------------------------------------------- + !| ATM/OCN SETUP (rasm_option2) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'RASM_OPTION2') .and. & + iamin_CPLID .and. ocn_present) then + + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ATMOCN2_BARRIER') + call t_drvstartf ('CPL:ATMOCN2',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (ocn_prognostic) then + ! Map ice to ocn + if (ice_c2_ocn) call prep_ocn_calc_i2x_ox(timer='CPL:atmocnp_ice2ocn') + + ! Map wav to ocn + if (wav_c2_ocn) call prep_ocn_calc_w2x_ox(timer='CPL:atmocnp_wav2ocn') + endif + + !---------------------------------------------------------- + !| atm/ocn flux on atm grid (rasm_option2 and aoflux_grid='atm') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'atm') then + ! compute o2x_ax for flux_atmocn, will be updated before atm merge + ! can use fractions because fractions here are consistent with fractions in atm_mrg + if (ocn_c2_atm) call prep_atm_calc_o2x_ax(fractions_ox,timer='CPL:atmoca_ocn2atm') + + call t_drvstartf ('CPL:atmocna_fluxa',barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ax => component_get_c2x_cx(atm(eai)) + o2x_ax => prep_atm_get_o2x_ax() ! array over all instances + xao_ax => prep_aoflux_get_xao_ax() ! array over all instances + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ax, o2x_ax(eoi), xao_ax(exi)) + enddo + call t_drvstopf ('CPL:atmocna_fluxa') + + if (atm_c2_ocn) call prep_aoflux_calc_xao_ox(timer='CPL:atmocna_atm2ocn') + endif ! aoflux_grid + + !---------------------------------------------------------- + !| atm/ocn flux on ocn grid (rasm_option2 and aoflux_grid='ocn') + !---------------------------------------------------------- + + if (trim(aoflux_grid) == 'ocn') then + call t_drvstartf ('CPL:atmocnp_fluxo',barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + eai = mod((exi-1),num_inst_atm) + 1 + eoi = mod((exi-1),num_inst_ocn) + 1 + efi = mod((exi-1),num_inst_frc) + 1 + a2x_ox => prep_ocn_get_a2x_ox() + o2x_ox => component_get_c2x_cx(ocn(eoi)) + xao_ox => prep_aoflux_get_xao_ox() + call seq_flux_atmocn_mct(infodata, tod, dtime, a2x_ox(eai), o2x_ox, xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_fluxo') + endif ! aoflux_grid + + !---------------------------------------------------------- + !| ocn prep-merge (rasm_option2) + !---------------------------------------------------------- + + xao_ox => prep_aoflux_get_xao_ox() + call prep_ocn_mrg(infodata, fractions_ox, xao_ox=xao_ox, timer_mrg='CPL:atmocnp_mrgx2o') + + ! Accumulate ocn inputs - form partial sum of tavg ocn inputs (virtual "send" to ocn) + call prep_ocn_accum(timer='CPL:atmocnp_accum') + + !---------------------------------------------------------- + !| ocn albedos (rasm_option2) + ! (MUST BE AFTER prep_ocn_mrg for swnet to ocn to be computed properly + !---------------------------------------------------------- + + call t_drvstartf ('CPL:atmocnp_ocnalb', barrier=mpicom_CPLID) + do exi = 1,num_inst_xao + efi = mod((exi-1),num_inst_frc) + 1 + eai = mod((exi-1),num_inst_atm) + 1 + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + a2x_ox => prep_ocn_get_a2x_ox() + call seq_flux_ocnalb_mct(infodata, ocn(1), a2x_ox(eai), fractions_ox(efi), xao_ox(exi)) + enddo + call t_drvstopf ('CPL:atmocnp_ocnalb') + + !---------------------------------------------------------- + !| ocn budget (rasm_option2) + !---------------------------------------------------------- + + if (do_budgets) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:BUDGET0_BARRIER') + call t_drvstartf ('CPL:BUDGET0',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + xao_ox => prep_aoflux_get_xao_ox() ! array over all instances + call seq_diag_ocn_mct(ocn(ens1), xao_ox(1), fractions_ox(ens1), infodata, & + do_o2x=.true., do_x2o=.true., do_xao=.true.) + call t_drvstopf ('CPL:BUDGET0',cplrun=.true.,budget=.true.) + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ATMOCN2',cplrun=.true.) + endif + + !---------------------------------------------------------- + !| OCN SETUP-SEND (rasm_option2) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) == 'RASM_OPTION2' ) .and. & + ocn_present .and. ocnrun_alarm) then + + !---------------------------------------------------- + ! "startup" wait (rasm_option2) + !---------------------------------------------------- + + if (iamin_CPLALLOCNID) then + ! want to know the time the ocean pes waited for the cpl pes + ! at the first ocnrun_alarm, min ocean wait is wait time + ! do not use t_barrierf here since it can be "off", use mpi_barrier + do eoi = 1,num_inst_ocn + if (ocn(eoi)%iamin_compid) call t_drvstartf ('CPL:C2O_INITWAIT') + enddo + call mpi_barrier(mpicom_CPLALLOCNID,ierr) + do eoi = 1,num_inst_ocn + if (ocn(eoi)%iamin_compid) call t_drvstopf ('CPL:C2O_INITWAIT') + enddo + cpl2ocn_first = .false. + endif + + !---------------------------------------------------- + !| ocn average (rasm_option2) + !---------------------------------------------------- + + if (iamin_CPLID .and. ocn_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:OCNPRE2_BARRIER') + call t_drvstartf ('CPL:OCNPRE2',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + ! finish accumulating ocean inputs + ! reset the value of x2o_ox with the value in x2oacc_ox + ! (module variable in prep_ocn_mod) + call prep_ocn_accum_avg(timer_accum='CPL:ocnprep_avg') + + call component_diag(infodata, ocn, flow='x2c', comment= 'send ocn', & + info_debug=info_debug, timer_diag='CPL:ocnprep_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:OCNPRE2',cplrun=.true.) + endif + + !---------------------------------------------------- + !| cpl -> ocn (rasm_option2) + !---------------------------------------------------- + + if (iamin_CPLALLOCNID .and. ocn_prognostic) then + call component_exch(ocn, flow='x2c', & + infodata=infodata, infodata_string='cpl2ocn_run', & + mpicom_barrier=mpicom_CPLALLOCNID, run_barriers=run_barriers, & + timer_barrier='CPL:C2O2_BARRIER', timer_comp_exch='CPL:C2O2', & + timer_map_exch='CPL:c2o2_ocnx2ocno', timer_infodata_exch='CPL:c2o2_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| ATM SETUP-SEND + !---------------------------------------------------------- + + if (atm_present .and. atmrun_alarm) then + + !---------------------------------------------------------- + !| atm prep-merge + !---------------------------------------------------------- + + if (iamin_CPLID .and. atm_prognostic) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ATMPREP_BARRIER') + call t_drvstartf ('CPL:ATMPREP',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + if (ocn_c2_atm) then + if (trim(aoflux_grid) == 'ocn') then + ! map xao_ox states and fluxes to xao_ax if fluxes were computed on ocn grid + call prep_aoflux_calc_xao_ax(fractions_ox, flds='states_and_fluxes', & + timer='CPL:atmprep_xao2atm') + endif + + ! recompute o2x_ax now for the merge with fractions associated with merge + call prep_atm_calc_o2x_ax(fractions_ox, timer='CPL:atmprep_ocn2atm') + + ! map xao_ox albedos to the atm grid, these are always computed on the ocean grid + call prep_aoflux_calc_xao_ax(fractions_ox, flds='albedos', timer='CPL:atmprep_alb2atm') + endif + + if (ice_c2_atm) then + call prep_atm_calc_i2x_ax(fractions_ix, timer='CPL:atmprep_ice2atm') + endif + + if (lnd_c2_atm) then + call prep_atm_calc_l2x_ax(fractions_lx, timer='CPL:atmprep_lnd2atm') + endif + + if (associated(xao_ax)) then + call prep_atm_mrg(infodata, fractions_ax, xao_ax=xao_ax, timer_mrg='CPL:atmprep_mrgx2a') + endif + + call component_diag(infodata, atm, flow='x2c', comment= 'send atm', info_debug=info_debug, & + timer_diag='CPL:atmprep_diagav') + + call t_drvstopf ('CPL:ATMPREP',cplrun=.true.) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif + + !---------------------------------------------------------- + !| cpl -> atm + !---------------------------------------------------------- + + if (iamin_CPLALLATMID .and. atm_prognostic) then + call component_exch(atm, flow='x2c', infodata=infodata, infodata_string='cpl2atm_run', & + mpicom_barrier=mpicom_CPLALLATMID, run_barriers=run_barriers, & + timer_barrier='CPL:C2A_BARRIER', timer_comp_exch='CPL:C2A', & + timer_map_exch='CPL:c2a_atmx2atmg', timer_infodata_exch='CPL:c2a_infoexch') + endif + + endif + + !---------------------------------------------------------- + !| RUN OCN MODEL (NOT cesm1_orig_tight or cesm1_mod_tight) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) /= 'CESM1_ORIG_TIGHT' .and. & + trim(cpl_seq_option) /= 'CESM1_MOD_TIGHT' ) .and. & + ocn_present .and. ocnrun_alarm) then + call component_run(Eclock_o, ocn, ocn_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2o_fluxes, & + seq_flds_c2x_fluxes=seq_flds_o2x_fluxes, & + comp_prognostic=ocn_prognostic, comp_num=comp_num_ocn, & + timer_barrier= 'CPL:OCN_RUN_BARRIER', timer_comp_run='CPL:OCN_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=ocn_layout) + endif + + !---------------------------------------------------------- + !| RUN ATM MODEL + !---------------------------------------------------------- + + if (atm_present .and. atmrun_alarm) then + call component_run(Eclock_a, atm, atm_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2a_fluxes, & + seq_flds_c2x_fluxes=seq_flds_a2x_fluxes, & + comp_prognostic=atm_prognostic, comp_num=comp_num_atm, & + timer_barrier= 'CPL:ATM_RUN_BARRIER', timer_comp_run='CPL:ATM_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod, comp_layout=atm_layout) + endif + + !---------------------------------------------------------- + !| RUN GLC MODEL + !---------------------------------------------------------- + + if (glc_present .and. glcrun_alarm) then + call component_run(Eclock_g, glc, glc_run, infodata, & + seq_flds_x2c_fluxes=seq_flds_x2g_fluxes, & + seq_flds_c2x_fluxes=seq_flds_g2x_fluxes, & + comp_prognostic=glc_prognostic, comp_num=comp_num_glc, & + timer_barrier= 'CPL:GLC_RUN_BARRIER', timer_comp_run='CPL:GLC_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=glc_layout) + endif + + !---------------------------------------------------------- + !| WAV RECV-POST + !---------------------------------------------------------- + + if (wav_present .and. wavrun_alarm) then + + !---------------------------------------------------------- + !| wav -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLWAVID) then + call component_exch(wav, flow='c2x', infodata=infodata, infodata_string='wav2cpl_run', & + mpicom_barrier=mpicom_CPLALLWAVID, run_barriers=run_barriers, & + timer_barrier='CPL:W2C_BARRIER', timer_comp_exch='CPL:W2C', & + timer_map_exch='CPL:w2c_wavw2wavx', timer_infodata_exch='CPL:w2c_infoexch') + endif + + !---------------------------------------------------------- + !| wav post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:WAVPOST_BARRIER') + call t_drvstartf ('CPL:WAVPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, wav, flow='c2x', comment= 'recv wav', & + info_debug=info_debug, timer_diag='CPL:wavpost_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:WAVPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| GLC RECV-POST + !---------------------------------------------------------- + + if (glc_present .and. glcrun_alarm) then + + !---------------------------------------------------------- + !| glc -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLGLCID) then + call component_exch(glc, flow='c2x', infodata=infodata, infodata_string='glc2cpl_run', & + mpicom_barrier=mpicom_CPLALLGLCID, run_barriers=run_barriers, & + timer_barrier='CPL:G2C_BARRIER', timer_comp_exch='CPL:G2C', & + timer_map_exch='CPL:g2c_glcg2glcx', timer_infodata_exch='CPL:g2c_infoexch') + endif + + !---------------------------------------------------------- + !| glc post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:GLCPOST_BARRIER') + call t_drvstartf ('CPL:GLCPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, glc, flow='c2x', comment= 'recv glc', & + info_debug=info_debug, timer_diag='CPL:glcpost_diagav') + + if (glc_c2_lnd) then + call prep_lnd_calc_g2x_lx(timer='CPL:glcpost_glc2lnd') + endif + + if (glc_c2_ice) then + call prep_ice_calc_g2x_ix(timer='CPL:glcpost_glc2ice') + endif + + if (glc_c2_ocn) then + call prep_ocn_calc_g2x_ox(timer='CPL:glcpost_glc2ocn') + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:GLCPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| ATM RECV-POST + !---------------------------------------------------------- + + if (atm_present .and. atmrun_alarm) then + + !---------------------------------------------------------- + !| atm -> cpl + !---------------------------------------------------------- + + if (iamin_CPLALLATMID) then + call component_exch(atm, flow='c2x', infodata=infodata, infodata_string='atm2cpl_run', & + mpicom_barrier=mpicom_CPLALLATMID, run_barriers=run_barriers, & + timer_barrier='CPL:A2C_BARRIER', timer_comp_exch='CPL:A2C', & + timer_map_exch='CPL:a2c_atma2atmx', timer_infodata_exch='CPL:a2c_infoexch') + endif + + !---------------------------------------------------------- + !| atm post + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:ATMPOST_BARRIER') + call t_drvstartf ('CPL:ATMPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, atm, flow='c2x', comment= 'recv atm', & + info_debug=info_debug, timer_diag='CPL:atmpost_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:ATMPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| Budget with new fractions + !---------------------------------------------------------- + + if (iamin_CPLID .and. do_budgets) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:BUDGET2_BARRIER') + + call t_drvstartf ('CPL:BUDGET2',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + if (atm_present) then + call seq_diag_atm_mct(atm(ens1), fractions_ax(ens1), infodata, & + do_a2x=.true., do_x2a=.true.) + endif + if (ice_present) then + call seq_diag_ice_mct(ice(ens1), fractions_ix(ens1), infodata, & + do_i2x=.true.) + endif + call t_drvstopf ('CPL:BUDGET2',cplrun=.true.,budget=.true.) + + call t_drvstartf ('CPL:BUDGET3',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + call seq_diag_accum_mct() + call t_drvstopf ('CPL:BUDGET3',cplrun=.true.,budget=.true.) + + call t_drvstartf ('CPL:BUDGETF',cplrun=.true.,budget=.true.,barrier=mpicom_CPLID) + if (.not. dead_comps) then + call seq_diag_print_mct(EClock_d,stop_alarm,budget_inst, & + budget_daily, budget_month, budget_ann, budget_ltann, budget_ltend) + endif + call seq_diag_zero_mct(EClock=EClock_d) + + call t_drvstopf ('CPL:BUDGETF',cplrun=.true.,budget=.true.) + endif + + !---------------------------------------------------------- + !| OCN RECV-POST (NOT cesm1_orig_tight and cesm1_mod_tight) + !---------------------------------------------------------- + + if ((trim(cpl_seq_option) /= 'CESM1_ORIG_TIGHT' .and. & + trim(cpl_seq_option) /= 'CESM1_MOD_TIGHT' ) .and. & + ocn_present .and. ocnnext_alarm) then + + !---------------------------------------------------------- + !| ocn -> cpl (NOT cesm1_orig_tight and cesm1_mod_tight) + !---------------------------------------------------------- + + if (iamin_CPLALLOCNID) then + call component_exch(ocn, flow='c2x', & + infodata=infodata, infodata_string='ocn2cpl_run', & + mpicom_barrier=mpicom_CPLALLOCNID, run_barriers=run_barriers, & + timer_barrier='CPL:O2C_BARRIER', timer_comp_exch='CPL:O2C', & + timer_map_exch='CPL:o2c_ocno2ocnx', timer_infodata_exch='CPL:o2c_infoexch') + endif + + !---------------------------------------------------------- + !| ocn post (NOT cesm1_orig_tight and cesm1_mod_tight) + !---------------------------------------------------------- + + if (iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:OCNPOST_BARRIER') + call t_drvstartf ('CPL:OCNPOST',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + call component_diag(infodata, ocn, flow='c2x', comment= 'recv ocn', & + info_debug=info_debug, timer_diag='CPL:ocnpost_diagav') + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:OCNPOST',cplrun=.true.) + endif + endif + + !---------------------------------------------------------- + !| Write driver restart file + !---------------------------------------------------------- + if ( (restart_alarm .or. drv_pause) .and. iamin_CPLID) then + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:RESTART_BARRIER') + call t_drvstartf ('CPL:RESTART',cplrun=.true.,barrier=mpicom_CPLID) + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (iamroot_CPLID) then + write(logunit,104) ' Write restart file at ',ymd,tod + call shr_sys_flush(logunit) + endif + + call seq_rest_write(EClock_d, seq_SyncClock, infodata, & + atm, lnd, ice, ocn, rof, glc, wav, esp, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx, trim(cpl_inst_tag)) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + call t_drvstopf ('CPL:RESTART',cplrun=.true.) + endif + + !---------------------------------------------------------- + !| Write history file, only AVs on CPLID + !---------------------------------------------------------- + + if (iamin_CPLID) then + + call cime_comp_barriers(mpicom=mpicom_CPLID, timer='CPL:HISTORY_BARRIER') + call t_drvstartf ('CPL:HISTORY',cplrun=.true.,barrier=mpicom_CPLID) + if ( history_alarm) then + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (iamroot_CPLID) then + write(logunit,104) ' Write history file at ',ymd,tod + call shr_sys_flush(logunit) + endif + + call seq_hist_write(infodata, EClock_d, & + atm, lnd, ice, ocn, rof, glc, wav, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx, trim(cpl_inst_tag)) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif + + if (do_histavg) then + call seq_hist_writeavg(infodata, EClock_d, & + atm, lnd, ice, ocn, rof, glc, wav, histavg_alarm, & + trim(cpl_inst_tag)) + endif + + if (do_hist_a2x) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=ncpl) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=ncpl, flds=hist_a2x_flds) + endif + enddo + endif + + if (do_hist_a2x1hri .and. t1hr_alarm) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x1hri_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1hi'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=24) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1hi'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=24, flds=hist_a2x1hri_flds) + endif + enddo + endif + + if (do_hist_a2x1hr) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x1hr_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1h'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=24, write_now=t1hr_alarm) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1h'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=24, write_now=t1hr_alarm, flds=hist_a2x1hr_flds) + endif + enddo + endif + + if (do_hist_a2x3hr) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x3hr_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x3h'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=8, write_now=t3hr_alarm) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x3h'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=8, write_now=t3hr_alarm, flds=hist_a2x3hr_flds) + endif + enddo + endif + + if (do_hist_a2x3hrp) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x3hrp_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x3h_prec'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=8, write_now=t3hr_alarm) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x3h_prec'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=8, write_now=t3hr_alarm, flds=hist_a2x3hrp_flds) + endif + enddo + endif + + if (do_hist_a2x24hr) then + do eai = 1,num_inst_atm + suffix = component_get_suffix(atm(eai)) + if (trim(hist_a2x24hr_flds) == 'all') then + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1d'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=1, write_now=t24hr_alarm) + else + call seq_hist_writeaux(infodata, EClock_d, atm(eai), flow='c2x', & + aname='a2x1d'//trim(suffix), dname='doma', & + nx=atm_nx, ny=atm_ny, nt=1, write_now=t24hr_alarm, flds=hist_a2x24hr_flds) + endif + enddo + endif + + if (do_hist_l2x1yr .and. glcrun_alarm) then + ! Use yr_offset=-1 so the file with fields from year 1 has time stamp + ! 0001-01-01 rather than 0002-01-01, etc. + do eli = 1,num_inst_lnd + suffix = component_get_suffix(lnd(eli)) + call seq_hist_writeaux(infodata, EClock_d, lnd(eli), flow='c2x', & + aname='l2x'//trim(suffix), dname='doml', & + nx=lnd_nx, ny=lnd_ny, nt=1, write_now=t1yr_alarm, yr_offset=-1) + enddo + endif + + if (do_hist_l2x) then + do eli = 1,num_inst_lnd + suffix = component_get_suffix(lnd(eli)) + call seq_hist_writeaux(infodata, EClock_d, lnd(eli), flow='c2x', & + aname='l2x'//trim(suffix), dname='doml', & + nx=lnd_nx, ny=lnd_ny, nt=ncpl) + enddo + endif + call t_drvstopf ('CPL:HISTORY',cplrun=.true.) + + endif + !---------------------------------------------------------- + !| RUN ESP MODEL + !---------------------------------------------------------- + if (esp_present .and. esprun_alarm) then + ! Make sure that all couplers are here in multicoupler mode before running ESP component + if (num_inst_driver > 1) then + call mpi_barrier(global_comm, ierr) + endif + call component_run(Eclock_e, esp, esp_run, infodata, & + comp_prognostic=esp_prognostic, comp_num=comp_num_esp, & + timer_barrier= 'CPL:ESP_RUN_BARRIER', timer_comp_run='CPL:ESP_RUN', & + run_barriers=run_barriers, ymd=ymd, tod=tod,comp_layout=esp_layout) + !--------------------------------------------------------------------- + !| ESP computes resume options for other components -- update everyone + !--------------------------------------------------------------------- + call seq_infodata_exchange(infodata, CPLALLESPID, 'esp2cpl_run') + endif + + !---------------------------------------------------------- + !| RESUME (read restart) if signaled + !---------------------------------------------------------- + call seq_infodata_GetData(infodata, cpl_resume=drv_resume) + if (len_trim(drv_resume) > 0) then + if (iamroot_CPLID) then + write(logunit,103) subname,' Reading restart (resume) file ',trim(drv_resume) + call shr_sys_flush(logunit) + end if + if (iamin_CPLID) then + call seq_rest_read(drv_resume, infodata, & + atm, lnd, ice, ocn, rof, glc, wav, esp, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx) + end if + ! Clear the resume file so we don't try to read it again + drv_resume = ' ' + call seq_infodata_PutData(infodata, cpl_resume=drv_resume) + end if + + !---------------------------------------------------------- + !| Timing and memory diagnostics + !---------------------------------------------------------- + + call t_drvstartf ('CPL:TSTAMP_WRITE',cplrun=.true.) + if (tod == 0 .or. info_debug > 1) then + if (iamroot_CPLID) then + call date_and_time(dstr,tstr) + Time_estep = mpi_wtime() + cktime = time_estep-time_bstep + cktime_acc(1) = cktime_acc(1) + cktime + cktime_cnt(1) = cktime_cnt(1) + 1 +#ifndef CPL_BYPASS + write(logunit,101) ' tStamp_write: model date = ',ymd,tod, & + ' wall clock = ',dstr(1:4),'-',dstr(5:6),'-',dstr(7:8),' ',& + tstr(1:2),':',tstr(3:4),':',tstr(5:6), & + ' avg dt = ',cktime_acc(1)/cktime_cnt(1),' dt = ',cktime +#endif + Time_bstep = mpi_wtime() + call shr_sys_flush(logunit) + if(cktime > max_cplstep_time .and. max_cplstep_time > 0.0) then + call shr_sys_abort(subname//'Wall clock time exceeds max_cplstep_time') + else if(max_cplstep_time < -0.05) then + ! if max_cplstep_time is < 0 we use abs(max_cplstep_time) + ! times the initial cktime value as a threshhold + max_cplstep_time = -(max_cplstep_time)*cktime + endif + endif + end if + if (tod == 0 .and. wall_time_limit > 0.0_r8 .and. .not. force_stop) then + time_erun = mpi_wtime() + ! time_*run is seconds, wall_time_limit is hours + wall_time = (time_erun - time_brun) / 3600._r8 ! convert secs to hrs + write(logunit,109) subname//' check wall_time_limit: ',wall_time, wall_time_limit + if (wall_time > wall_time_limit) then + force_stop = .true. + force_stop_tod = 0 + if (trim(force_stop_at) == 'month') then + call shr_cal_date2ymd(ymd,year,month,day) + month = month + 1 + do while (month > 12) + month = month - 12 + year = year + 1 + enddo + call shr_cal_ymd2date(year,month,1,force_stop_ymd) + elseif (trim(force_stop_at) == 'year') then ! next year + call shr_cal_date2ymd(ymd,year,month,day) + call shr_cal_ymd2date(year+1,1,1,force_stop_ymd) + elseif (trim(force_stop_at) == 'day') then ! next day + ymdtmp = ymd + call shr_cal_advDateInt(1,'days' ,ymdtmp,0,force_stop_ymd,todtmp,calendar) + else ! day is default + ymdtmp = ymd + call shr_cal_advDateInt(1,'days' ,ymdtmp,0,force_stop_ymd,todtmp,calendar) + endif + write(logunit,108) subname//' reached wall_time_limit (hours) =',wall_time_limit, & + ' :stop at ',force_stop_ymd + endif + endif +#ifndef CPL_BYPASS + if (tod == 0 .or. info_debug > 1) then + !! Report on memory usage + !! For now, just look at the first instance of each component + if ( iamroot_CPLID .or. & + ocn(ens1)%iamroot_compid .or. & + atm(ens1)%iamroot_compid .or. & + lnd(ens1)%iamroot_compid .or. & + ice(ens1)%iamroot_compid .or. & + glc(ens1)%iamroot_compid .or. & + wav(ens1)%iamroot_compid) then + call shr_mem_getusage(msize,mrss,.true.) + + write(logunit,105) ' memory_write: model date = ',ymd,tod, & + ' memory = ',msize,' MB (highwater) ',mrss,' MB (usage)', & + ' (pe=',iam_GLOID,' comps=',trim(complist)//')' + endif + endif +#endif + if (info_debug > 1) then + if (iamroot_CPLID) then + call seq_infodata_GetData(infodata,nextsw_cday=nextsw_cday) + ! write(logunit,106) ' nextsw_cday = ',nextsw_cday + write(logunit,*) ' nextsw_cday = ',nextsw_cday + endif + endif + call t_drvstopf ('CPL:TSTAMP_WRITE',cplrun=.true.) + + call t_stopf ('CPL:RUN_LOOP', hashint(1)) + + ! --- Write out performance data + call t_startf ('CPL:TPROF_WRITE') + if ((tprof_alarm) .or. ((tod == 0) .and. in_first_day)) then + + if ((tod == 0) .and. in_first_day) then + in_first_day = .false. + endif + call t_adj_detailf(+1) + + call t_startf("CPL:sync1_tprof") + call mpi_barrier(mpicom_GLOID,ierr) + call t_stopf("CPL:sync1_tprof") + + write(timing_file,'(a,i8.8,a1,i5.5)') & + trim(tchkpt_dir)//"/cesm_timing"//trim(cpl_inst_tag)//"_",ymd,"_",tod + + call t_set_prefixf("CPL:") + if (output_perf) then + call t_prf(filename=trim(timing_file), mpicom=mpicom_GLOID, & + num_outpe=0, output_thispe=output_perf) + else + call t_prf(filename=trim(timing_file), mpicom=mpicom_GLOID, & + num_outpe=0) + endif + call t_unset_prefixf() + + call t_startf("CPL:sync2_tprof") + call mpi_barrier(mpicom_GLOID,ierr) + call t_stopf("CPL:sync2_tprof") + + call t_adj_detailf(-1) + endif + call t_stopf ('CPL:TPROF_WRITE') + + if (barrier_alarm) then + call t_drvstartf ('CPL:BARRIERALARM',cplrun=.true.) + call mpi_barrier(mpicom_GLOID,ierr) + call t_drvstopf ('CPL:BARRIERALARM',cplrun=.true.) + endif + + enddo ! driver run loop + + !|---------------------------------------------------------- + !| End of driver time step loop + !|--------------------------------------------------------- + + call t_startf ('CPL:RUN_LOOP_BSTOP') + call mpi_barrier(mpicom_GLOID,ierr) + call t_stopf ('CPL:RUN_LOOP_BSTOP') + + Time_end = mpi_wtime() + + end subroutine cime_run + +!=============================================================================== +!******************************************************************************* +!=============================================================================== + + subroutine cime_final() + + use shr_pio_mod, only : shr_pio_finalize + use shr_wv_sat_mod, only: shr_wv_sat_final + + !------------------------------------------------------------------------ + ! Finalization of all models + !------------------------------------------------------------------------ + + call t_barrierf ('CPL:FINAL_BARRIER', mpicom_GLOID) + call t_startf ('CPL:FINAL') + call t_adj_detailf(+1) + + call t_startf('CPL:cime_final') + call t_adj_detailf(+1) + + call seq_timemgr_EClockGetData( EClock_d, stepno=endstep) + call shr_mem_getusage(msize,mrss) + + call component_final(EClock_a, atm, atm_final) + call component_final(EClock_l, lnd, lnd_final) + call component_final(EClock_r, rof, rof_final) + call component_final(EClock_i, ice, ice_final) + call component_final(EClock_o, ocn, ocn_final) + call component_final(EClock_g, glc, glc_final) + call component_final(EClock_w, wav, wav_final) + + !------------------------------------------------------------------------ + ! End the run cleanly + !------------------------------------------------------------------------ + + call shr_wv_sat_final() + + call shr_pio_finalize( ) + + call shr_mpi_min(msize ,msize0,mpicom_GLOID,' driver msize0', all=.true.) + call shr_mpi_max(msize ,msize1,mpicom_GLOID,' driver msize1', all=.true.) + call shr_mpi_min(mrss ,mrss0,mpicom_GLOID,' driver mrss0', all=.true.) + call shr_mpi_max(mrss ,mrss1,mpicom_GLOID,' driver mrss1', all=.true.) + + if (iamroot_CPLID )then + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=ymd, curr_tod=tod, dtime=dtime) + simDays = (endStep-begStep)*dtime/(24._r8*3600._r8) + write(logunit,'(//)') + write(logunit,FormatA) subname, 'SUCCESSFUL TERMINATION OF CPL7-CESM' + write(logunit,FormatD) subname, ' at YMD,TOD = ',ymd,tod + write(logunit,FormatR) subname, '# simulated days (this run) = ', simDays + write(logunit,FormatR) subname, 'compute time (hrs) = ', (Time_end-Time_begin)/3600._r8 + if ( (Time_end /= Time_begin) .and. (simDays /= 0.0_r8) )then + SYPD = shr_const_cday*simDays/(days_per_year*(Time_end-Time_begin)) + write(logunit,FormatR) subname, '# simulated years / cmp-day = ', SYPD + endif + write(logunit,FormatR) subname,' pes min memory highwater (MB) = ',msize0 + write(logunit,FormatR) subname,' pes max memory highwater (MB) = ',msize1 + write(logunit,FormatR) subname,' pes min memory last usage (MB) = ',mrss0 + write(logunit,FormatR) subname,' pes max memory last usage (MB) = ',mrss1 + write(logunit,'(//)') + close(logunit) + endif + + call t_adj_detailf(-1) + call t_stopf('CPL:cime_final') + + call t_adj_detailf(-1) + call t_stopf ('CPL:FINAL') + + call t_startf("sync3_tprof") + call mpi_barrier(mpicom_GLOID,ierr) + call t_stopf("sync3_tprof") + + if (output_perf) then + call t_prf(trim(timing_dir)//'/model_timing'//trim(cpl_inst_tag), & + mpicom=mpicom_GLOID, output_thispe=output_perf) + else + call t_prf(trim(timing_dir)//'/model_timing'//trim(cpl_inst_tag), & + mpicom=mpicom_GLOID) + endif + + call t_finalizef() + +end subroutine cime_final + +!=============================================================================== +!******************************************************************************* +!=============================================================================== + +subroutine seq_cime_printlogheader() + + !----------------------------------------------------------------------- + ! + ! Purpose: Print basic information on what this driver program is + ! to the logfile. + ! + !----------------------------------------------------------------------- + ! + ! Local variables + ! + + character(len=8) :: cdate ! System date + character(len=8) :: ctime ! System time + integer :: values(8) + character :: date*8, time*10, zone*5 + character(len=cs) :: cime_model + +!------------------------------------------------------------------------------- + + call date_and_time (date, time, zone, values) + call seq_infodata_GetData(infodata, cime_model=cime_model) + cdate(1:2) = date(5:6) + cdate(3:3) = '/' + cdate(4:5) = date(7:8) + cdate(6:6) = '/' + cdate(7:8) = date(3:4) + ctime(1:2) = time(1:2) + ctime(3:3) = ':' + ctime(4:5) = time(3:4) + ctime(6:6) = ':' + ctime(7:8) = time(5:6) + write(logunit,F00) '------------------------------------------------------------' + write(logunit,F00) ' Common Infrastructure for Modeling the Earth (CIME) CPL7 ' + write(logunit,F00) '------------------------------------------------------------' + write(logunit,F00) ' (Online documentation is available on the CIME ' + write(logunit,F00) ' github: http://esmci.github.io/cime/) ' + write(logunit,F00) ' License information is available as a link from above ' + write(logunit,F00) '------------------------------------------------------------' + write(logunit,F00) ' MODEL ',cime_model + write(logunit,F00) '------------------------------------------------------------' + write(logunit,F00) ' DATE ',cdate, ' TIME ', ctime + write(logunit,F00) '------------------------------------------------------------' + write(logunit,*)' ' + write(logunit,*)' ' + +end subroutine seq_cime_printlogheader + +!=============================================================================== + +subroutine cime_comp_barriers(mpicom, timer) + integer , intent(in) :: mpicom + character(len=*), intent(in) :: timer + integer :: ierr + + if (run_barriers) then + call t_drvstartf (trim(timer)) + call mpi_barrier(mpicom,ierr) + call t_drvstopf (trim(timer)) + endif +end subroutine cime_comp_barriers + +subroutine cime_cpl_init(comm_in, comm_out, num_inst_driver, id) + !----------------------------------------------------------------------- + ! + ! Initialize multiple coupler instances, if requested + ! + !----------------------------------------------------------------------- + + implicit none + + integer , intent(in) :: comm_in + integer , intent(out) :: comm_out + integer , intent(out) :: num_inst_driver + integer , intent(out) :: id ! instance ID, starts from 1 + ! + ! Local variables + ! + integer :: ierr, inst_comm, mype, nu, numpes !, pes + integer :: ninst_driver, drvpes + character(len=*), parameter :: subname = '(cime_cpl_init) ' + + namelist /cime_driver_inst/ ninst_driver + + call shr_mpi_commrank(comm_in, mype , ' cime_cpl_init') + call shr_mpi_commsize(comm_in, numpes, ' cime_cpl_init') + + num_inst_driver = 1 + id = 0 + + if (mype == 0) then + ! Read coupler namelist if it exists + ninst_driver = 1 + nu = shr_file_getUnit() + open(unit = nu, file = NLFileName, status = 'old', iostat = ierr) + rewind(unit = nu) + ierr = 1 + do while ( ierr /= 0 ) + read(unit = nu, nml = cime_driver_inst, iostat = ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' end of file or end of record condition' ) + endif + enddo + close(unit = nu) + call shr_file_freeUnit(nu) + num_inst_driver = max(ninst_driver, 1) + end if + + call shr_mpi_bcast(num_inst_driver, comm_in, 'ninst_driver') + + if (mod(numpes, num_inst_driver) /= 0) then + call shr_sys_abort(subname // & + ' : Total PE number must be a multiple of coupler instance number') + end if + + if (num_inst_driver == 1) then + call mpi_comm_dup(comm_in, comm_out, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_dup') + else + id = mype * num_inst_driver / numpes + 1 + call mpi_comm_split(comm_in, id, 0, comm_out, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_split') + end if + call shr_mpi_commsize(comm_out, drvpes, ' cime_cpl_init') +end subroutine cime_cpl_init + +end module cime_comp_mod diff --git a/driver-mct/main/cime_driver.F90 b/driver-mct/main/cime_driver.F90 new file mode 100644 index 000000000000..d4e58745ac62 --- /dev/null +++ b/driver-mct/main/cime_driver.F90 @@ -0,0 +1,111 @@ +program cime_driver + +!------------------------------------------------------------------------------- +! +! Purpose: Main program for a CIME-driven model. Can have different +! land, sea-ice, and ocean models plugged in at compile-time. +! These models can be either: stub, dead, data, or active +! components or some combination of the above. +! +! stub -------- Do nothing. +! dead -------- Send analytic data back. +! data -------- Send data back interpolated from input files. +! active ------ Prognostically simulate the given component. +! +! Method: Call appropriate initialization, run (time-stepping), and +! finalization routines. +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! share code & libs + !---------------------------------------------------------------------------- + use shr_kind_mod, only : r8 => SHR_KIND_R8 + use shr_kind_mod, only : i8 => SHR_KIND_I8 + use shr_sys_mod, only : shr_sys_irtc + use perf_mod, only : t_startf, t_adj_detailf, t_stopf, t_startstop_valsf + use ESMF, only : ESMF_Initialize, ESMF_Finalize + use seq_comm_mct, only : esmf_logfile_kind + use cime_comp_mod, only : cime_pre_init1 + use cime_comp_mod, only : cime_pre_init2 + use cime_comp_mod, only : cime_init + use cime_comp_mod, only : cime_run + use cime_comp_mod, only : cime_final + + implicit none + + !-------------------------------------------------------------------------- + ! timing variables + !-------------------------------------------------------------------------- + integer(i8) :: beg_count, end_count, irtc_rate + real(r8) :: cime_pre_init1_time, ESMF_Initialize_time, & + cime_pre_init2_time, cime_init_time_adjustment + + !-------------------------------------------------------------------------- + ! Setup and initialize the communications and logging. + !-------------------------------------------------------------------------- + beg_count = shr_sys_irtc(irtc_rate) + + call cime_pre_init1() + + end_count = shr_sys_irtc(irtc_rate) + cime_pre_init1_time = real( (end_count-beg_count), r8)/real(irtc_rate, r8) + + !-------------------------------------------------------------------------- + ! Initialize ESMF. This is done outside of the ESMF_INTERFACE ifdef + ! because it is needed for the time manager, even if the ESMF_INTERFACE + ! is not used. + !-------------------------------------------------------------------------- + beg_count = shr_sys_irtc(irtc_rate) + + call ESMF_Initialize(logkindflag=esmf_logfile_kind) + + end_count = shr_sys_irtc(irtc_rate) + ESMF_Initialize_time = real( (end_count-beg_count), r8)/real(irtc_rate, r8) + + !-------------------------------------------------------------------------- + ! Read in the configuration information and initialize the time manager. + !-------------------------------------------------------------------------- + ! Timer initialization has to be after determination of the maximum number + ! of threads used across all components, so called inside of + ! cime_pre_init2, as are t_startf and t_stopf for CPL:INIT and + ! cime_pre_init2. + !-------------------------------------------------------------------------- + beg_count = shr_sys_irtc(irtc_rate) + + call cime_pre_init2() + + end_count = shr_sys_irtc(irtc_rate) + cime_pre_init2_time = real( (end_count-beg_count), r8)/real(irtc_rate, r8) + + !-------------------------------------------------------------------------- + ! Call the initialize, run and finalize routines. + !-------------------------------------------------------------------------- + + call t_startf('CPL:INIT') + call t_adj_detailf(+1) + + call t_startstop_valsf('CPL:cime_pre_init1', walltime=cime_pre_init1_time) + call t_startstop_valsf('CPL:ESMF_Initialize', walltime=ESMF_Initialize_time) + call t_startstop_valsf('CPL:cime_pre_init2', walltime=cime_pre_init2_time) + + call cime_init() + + call t_adj_detailf(-1) + call t_stopf('CPL:INIT') + + cime_init_time_adjustment = cime_pre_init1_time & + + ESMF_Initialize_time & + + cime_pre_init2_time + call t_startstop_valsf('CPL:INIT', walltime=cime_init_time_adjustment, & + callcount=0) + + call cime_run() + call cime_final() + + !-------------------------------------------------------------------------- + ! Clean-up + !-------------------------------------------------------------------------- + call ESMF_Finalize( ) + +end program cime_driver diff --git a/driver-mct/main/component_mod.F90 b/driver-mct/main/component_mod.F90 new file mode 100644 index 000000000000..10408d98fbbb --- /dev/null +++ b/driver-mct/main/component_mod.F90 @@ -0,0 +1,911 @@ +module component_mod + + !---------------------------------------------------------------------------- + ! share code & libs + !---------------------------------------------------------------------------- + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use shr_const_mod, only: shr_const_cday + use shr_file_mod, only: shr_file_setLogLevel, shr_file_setLogUnit + use shr_file_mod, only: shr_file_setIO, shr_file_getUnit + use shr_scam_mod, only: shr_scam_checkSurface + use shr_mpi_mod, only: shr_mpi_min, shr_mpi_max + use shr_mem_mod, only: shr_mem_init, shr_mem_getusage + use shr_cal_mod, only: shr_cal_date2ymd + use shr_orb_mod, only: shr_orb_params + use shr_reprosum_mod, only: shr_reprosum_setopts + use seq_comm_mct, only: GLOID, CPLID, logunit + use seq_comm_mct, only: seq_comm_iamin, seq_comm_namelen, num_inst_frc + use seq_comm_mct, only: seq_comm_suffix, seq_comm_name, seq_comm_setnthreads + use seq_comm_mct, only: seq_comm_getinfo => seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_putData, seq_infodata_GetData + use seq_infodata_mod, only: seq_infodata_exchange, seq_infodata_type + use seq_diag_mct, only: seq_diag_avect_mct + use seq_map_type_mod + use seq_map_mod + use t_drv_timers_mod + use component_type_mod + use seq_cdata_mod, only : seq_cdata + use mct_mod ! mct_ wrappers for mct lib + use perf_mod + use ESMF + use seq_flds_mod, only: nan_check_component_fields + implicit none + +#include + + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: component_init_pre + public :: component_init_cc ! mct and esmf versions + public :: component_init_cx + public :: component_init_aream + public :: component_init_areacor + public :: component_run ! mct and esmf versions + public :: component_final ! mct and esmf versions + public :: component_exch + public :: component_diag + + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + logical :: iamroot_GLOID, iamroot_CPLID ! GLOID, CPLID masterproc + logical :: iamin_CPLID ! true => pe associated with CPLID + integer :: mpicom_GLOID, mpicom_CPLID ! GLOID, CPLID mpi communicator + integer :: nthreads_GLOID, nthreads_CPLID + logical :: drv_threading + + !=============================================================================== + +contains + + !=============================================================================== + + subroutine component_init_pre(comp, compid, cplcompid, cplallcompid, & + infodata, ntype) + + !--------------------------------------------------------------- + ! Initialize driver rearrangers and AVs on driver + ! Initialize cdata_*x data + ! Zero out x2*_** in case it never gets used then it'll produce zeros in diags + ! For ensembles, create only a single dom_*x for the coupler based on the + ! first ensemble member. otherwise, just extend the dom_** and dom_*x to + ! other ensemble members. + ! + ! Arguments + type(component_type) , intent(inout) :: comp(:) + integer , intent(in) :: compid(:) + integer , intent(in) :: cplcompid(:) + integer , intent(in) :: cplallcompid + type (seq_infodata_type) , intent(inout), target :: infodata + character(len=3) , intent(in) :: ntype + ! + ! Local Variables + integer :: eci ! index + character(*), parameter :: subname = '(component_init_pre)' + !--------------------------------------------------------------- + + ! initialize module variables (this is repetitive here- but does not require a different routine) + + call seq_infodata_getdata(infodata, drv_threading=drv_threading) + call seq_comm_getinfo(GLOID, mpicom=mpicom_GLOID, iamroot=iamroot_GLOID, nthreads=nthreads_GLOID) + call seq_comm_getinfo(CPLID, mpicom=mpicom_CPLID, iamroot=iamroot_CPLID, nthreads=nthreads_CPLID) + iamin_CPLID = seq_comm_iamin(CPLID) + + ! Initialize component type variables + do eci = 1,size(comp) + + comp(eci)%compid = compid(eci) + comp(eci)%cplcompid = cplcompid(eci) + comp(eci)%cplallcompid = cplallcompid + + call seq_comm_getinfo(comp(eci)%cplallcompid, mpicom=comp(eci)%mpicom_cplallcompid) + call seq_comm_getinfo(comp(eci)%cplcompid , mpicom=comp(eci)%mpicom_cplcompid) + call seq_comm_getinfo(comp(eci)%compid , mpicom=comp(eci)%mpicom_compid) + call seq_comm_getinfo(comp(eci)%compid , iamroot=comp(eci)%iamroot_compid) + call seq_comm_getinfo(comp(eci)%compid , nthreads=comp(eci)%nthreads_compid) + + comp(eci)%iamin_compid = seq_comm_iamin (comp(eci)%compid) + comp(eci)%iamin_cplcompid = seq_comm_iamin (comp(eci)%cplcompid) + comp(eci)%iamin_cplallcompid = seq_comm_iamin (comp(eci)%cplallcompid) + comp(eci)%suffix = seq_comm_suffix(comp(eci)%compid) + comp(eci)%name = seq_comm_name (comp(eci)%compid) + comp(eci)%ntype = ntype(1:3) + comp(eci)%oneletterid = ntype(1:1) + + if (eci == 1) then + allocate(comp(1)%dom_cx) + allocate(comp(1)%gsmap_cx) + else + comp(eci)%dom_cx => comp(1)%dom_cx + comp(eci)%gsmap_cx => comp(1)%gsmap_cx + end if + + ! Set cdata_cc - unique for each instance + allocate(comp(eci)%dom_cc) + allocate(comp(eci)%gsmap_cc) + allocate(comp(eci)%cdata_cc) + comp(eci)%cdata_cc%name = 'cdata_'//ntype(1:1)//ntype(1:1) + comp(eci)%cdata_cc%ID = comp(eci)%compid + comp(eci)%cdata_cc%mpicom = comp(eci)%mpicom_compid + comp(eci)%cdata_cc%dom => comp(eci)%dom_cc + comp(eci)%cdata_cc%gsmap => comp(eci)%gsmap_cc + comp(eci)%cdata_cc%infodata => infodata + + ! Determine initial value of comp_present in infodata - to do - add this to component + +#ifdef CPRPGI + if (comp(1)%oneletterid == 'a') call seq_infodata_getData(infodata, atm_present=comp(eci)%present) + if (comp(1)%oneletterid == 'l') call seq_infodata_getData(infodata, lnd_present=comp(eci)%present) + if (comp(1)%oneletterid == 'i') call seq_infodata_getData(infodata, ice_present=comp(eci)%present) + if (comp(1)%oneletterid == 'o') call seq_infodata_getData(infodata, ocn_present=comp(eci)%present) + if (comp(1)%oneletterid == 'r') call seq_infodata_getData(infodata, rof_present=comp(eci)%present) + if (comp(1)%oneletterid == 'g') call seq_infodata_getData(infodata, glc_present=comp(eci)%present) + if (comp(1)%oneletterid == 'w') call seq_infodata_getData(infodata, wav_present=comp(eci)%present) + if (comp(1)%oneletterid == 'e') call seq_infodata_getData(infodata, esp_present=comp(eci)%present) +#else + call seq_infodata_getData(comp(1)%oneletterid, infodata, comp_present=comp(eci)%present) +#endif + end do + + end subroutine component_init_pre + + !=============================================================================== + + subroutine component_init_cc(Eclock, comp, comp_init, infodata, NLFilename, & + seq_flds_x2c_fluxes, seq_flds_c2x_fluxes) + + !--------------------------------------------------------------- + ! + ! Arguments + type(ESMF_Clock) , intent(inout) :: EClock + type(component_type) , intent(inout) :: comp(:) + interface + subroutine comp_init( Eclock, cdata, x2c, c2x, nlfilename) + use ESMF , only: ESMF_Clock + use seq_cdata_mod, only: seq_cdata + use mct_mod , only: mct_avect + implicit none + type(ESMF_Clock), intent(inout) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2c + type(mct_aVect) , intent(inout) :: c2x + character(len=*), optional, intent(IN) :: NLFilename ! Namelist filename + end subroutine comp_init + end interface + type (seq_infodata_type) , intent(inout) :: infodata + character(len=*) , intent(in) :: NLFilename + character(len=*) , intent(in), optional :: seq_flds_x2c_fluxes + character(len=*) , intent(in), optional :: seq_flds_c2x_fluxes + ! + ! Local Variables + integer :: k1, k2 + integer :: eci + character(*), parameter :: subname = '(component_init_cc:mct)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + ! **** Initialize component - this initializes x2c_cc and c2x_cc *** + ! the following will call the appropriate comp_init_mct routine + + call t_set_prefixf(comp(1)%oneletterid//"_i:") + + if (comp(1)%iamin_cplallcompid) then + call seq_infodata_exchange(infodata, comp(1)%cplallcompid, & + 'cpl2'//comp(1)%ntype(1:3)//'_init') + end if + + ! The following initializes the component instance cdata_cc (gsmap and dom), + ! x2c_cc and c2x_cc + + do eci = 1,size(comp) + if (iamroot_CPLID .and. comp(eci)%present) then + write(logunit,F00) 'Initialize component '//trim(comp(eci)%ntype) + call shr_sys_flush(logunit) + endif + + if (.not. associated(comp(eci)%x2c_cc)) allocate(comp(eci)%x2c_cc) + if (.not. associated(comp(eci)%c2x_cc)) then + allocate(comp(eci)%c2x_cc) + ! this is needed for check_fields + nullify(comp(eci)%c2x_cc%rattr) + endif + if (comp(eci)%iamin_compid .and. comp(eci)%present) then + if (drv_threading) call seq_comm_setnthreads(comp(eci)%nthreads_compid) + call shr_sys_flush(logunit) + + if (present(seq_flds_x2c_fluxes)) then + call mct_avect_vecmult(comp(eci)%x2c_cc, comp(eci)%drv2mdl, seq_flds_x2c_fluxes, mask_spval=.true.) + end if + + call t_startf('comp_init') + call comp_init( EClock, comp(eci)%cdata_cc, comp(eci)%x2c_cc, comp(eci)%c2x_cc, & + NLFilename=NLFilename ) + call t_stopf('comp_init') + if(nan_check_component_fields) then + call t_drvstartf ('check_fields') + call check_fields(comp(eci), eci) + call t_drvstopf ('check_fields') + end If + + if (present(seq_flds_c2x_fluxes)) then + call mct_avect_vecmult(comp(eci)%c2x_cc, comp(eci)%mdl2drv, seq_flds_c2x_fluxes, mask_spval=.true.) + end if + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + end if + end do + + if (comp(1)%iamin_cplcompid) then + call seq_infodata_exchange(infodata, comp(1)%cplcompid, & + comp(1)%ntype(1:3)//'2cpl_init') + endif + + ! Determine final value of comp_present in infodata (after component initialization) + + do eci = 1,size(comp) +#ifdef CPRPGI + if (comp(1)%oneletterid == 'a') call seq_infodata_getData(infodata, atm_present=comp(eci)%present) + if (comp(1)%oneletterid == 'l') call seq_infodata_getData(infodata, lnd_present=comp(eci)%present) + if (comp(1)%oneletterid == 'i') call seq_infodata_getData(infodata, ice_present=comp(eci)%present) + if (comp(1)%oneletterid == 'o') call seq_infodata_getData(infodata, ocn_present=comp(eci)%present) + if (comp(1)%oneletterid == 'r') call seq_infodata_getData(infodata, rof_present=comp(eci)%present) + if (comp(1)%oneletterid == 'g') call seq_infodata_getData(infodata, glc_present=comp(eci)%present) + if (comp(1)%oneletterid == 'w') call seq_infodata_getData(infodata, wav_present=comp(eci)%present) + if (comp(1)%oneletterid == 'e') call seq_infodata_getData(infodata, esp_present=comp(eci)%present) +#else + call seq_infodata_getData(comp(1)%oneletterid, infodata, comp_present=comp(eci)%present) +#endif + end do + + + ! Initialize aream, set it to area for now until maps are read + ! in some cases, maps are not read at all !! + ! Entire domain must have reasonable values before calling xxx2xxx init + + do eci = 1,size(comp) + if (comp(eci)%iamin_compid .and. comp(eci)%present .and. & + (comp(1)%oneletterid /= 'e')) then + if (drv_threading) call seq_comm_setnthreads(comp(eci)%nthreads_compid) + k1 = mct_aVect_indexRa(comp(eci)%cdata_cc%dom%data, "area" ,perrWith='aa area ') + k2 = mct_aVect_indexRa(comp(eci)%cdata_cc%dom%data, "aream" ,perrWith='aa aream') + + comp(eci)%cdata_cc%dom%data%rAttr(k2,:) = comp(eci)%cdata_cc%dom%data%rAttr(k1,:) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif + end do + + call t_unset_prefixf() + + end subroutine component_init_cc + + !=============================================================================== + + subroutine component_init_cx(comp, infodata) + + !--------------------------------------------------------------- + ! Uses + use cplcomp_exchange_mod, only: seq_mctext_gsmapinit, seq_mctext_avInit + use cplcomp_exchange_mod, only: seq_mctext_avExtend, seq_mctext_gGridInit + use cplcomp_exchange_mod, only: seq_map_init_exchange, seq_map_map_exchange + use seq_domain_mct, only: seq_domain_compare + use mct_mod, only: mct_ggrid_clean + ! + ! Arguments + type(component_type) , intent(inout) :: comp(:) + type (seq_infodata_type) , intent(inout) :: infodata + ! + ! Local Variables + integer :: eci + integer :: rc ! return code + type(mct_gGrid) :: dom_tmp ! temporary + character(*), parameter :: subname = '(component_init_cx)' + character(*), parameter :: F0I = "('"//subname//" : ', A, 2i8 )" + !--------------------------------------------------------------- + + ! Initialize driver rearrangers and AVs on driver + ! Initialize cdata_*x data + ! Zero out x2*_** in case it never gets used then it'll produce zeros in diags + ! For ensembles, create only a single dom_*x for the coupler based on the + ! first ensemble member. otherwise, just extend the dom_** and dom_*x to + ! other ensemble members. + + do eci = 1,size(comp) + if (comp(eci)%present) then + + if (iamroot_CPLID) then + write(logunit,*) ' ' + call shr_sys_flush(logunit) + end if + + if (comp(eci)%iamin_cplcompid) then + + ! Create gsmap_cx (note that comp(eci)%gsmap_cx all point to comp(1)%gsmap_cx + ! This will only be valid on the coupler pes + if (eci == 1) then + if (iamroot_CPLID) then + write(logunit,F0I) 'creating gsmap_cx for '//comp(eci)%ntype(1:3) + call shr_sys_flush(logunit) + end if + call seq_mctext_gsmapInit(comp(1)) + endif + + ! Create mapper_Cc2x and mapper_Cx2c + allocate(comp(eci)%mapper_Cc2x, comp(eci)%mapper_Cx2c) + if (iamroot_CPLID) then + write(logunit,F0I) 'Initializing mapper_C'//comp(eci)%ntype(1:1)//'2x',eci + call shr_sys_flush(logunit) + end if + call seq_map_init_exchange(comp(eci), flow='c2x', mapper=comp(eci)%mapper_Cc2x) + if (iamroot_CPLID) then + write(logunit,F0I) 'Initializing mapper_Cx2'//comp(eci)%ntype(1:1),eci + call shr_sys_flush(logunit) + end if + call seq_map_init_exchange(comp(eci), flow='x2c', mapper=comp(eci)%mapper_Cx2c) + + ! Create x2c_cx and c2x_cx + allocate(comp(eci)%x2c_cx, comp(eci)%c2x_cx) + call seq_mctext_avinit(comp(eci), flow='x2c') + call seq_mctext_avinit(comp(eci), flow='c2x') + + ! Create dom_cx (note that comp(eci)%dom_cx all point to comp(1)%dom_cx + ! Then verify other ensembles have same domain by comparing to dom_cx + if (eci == 1) then ! create dom_cx + if (iamroot_CPLID) then + write(logunit,F0I) 'creating dom_cx' + call shr_sys_flush(logunit) + end if + call seq_mctext_gGridInit(comp(1)) + call seq_map_map_exchange(comp(1), flow='c2x', dom_flag=.true., msgtag=comp(1)%cplcompid*100+1*10+1) + else if (eci > 1) then + if (iamroot_CPLID) then + write(logunit,F0I) 'comparing comp domain ensemble number ',eci + call shr_sys_flush(logunit) + end if + call seq_mctext_avExtend(comp(eci)%dom_cx%data, cplid, comp(eci)%cplcompid) + call seq_mctext_gGridInit(comp(eci), dom_tmp) + call seq_map_map_exchange(comp(eci), flow='c2x', dom_flag=.true., dom_tmp=dom_tmp) + if (iamin_CPLID) then + call seq_domain_compare(comp(eci)%dom_cx, dom_tmp, mpicom_CPLID) + end if + call mct_ggrid_clean(dom_tmp,rc) + endif + + call mct_avect_zero(comp(eci)%x2c_cc) + call mct_avect_zero(comp(eci)%x2c_cx) + + end if ! if comp(eci)%iamin_cplcompid + end if ! if comp(eci)%present + end do ! end of eci loop + + end subroutine component_init_cx + + !=============================================================================== + + subroutine component_init_aream(infodata, rof_c2_ocn, samegrid_ao, samegrid_al, & + samegrid_ro, samegrid_lg) + + !--------------------------------------------------------------- + ! Description + ! Update (read) aream in domains where appropriate - ON cpl pes + ! + ! Uses + use prep_ocn_mod, only : prep_ocn_get_mapper_Fa2o + use prep_lnd_mod, only : prep_lnd_get_mapper_Sa2l + use prep_ice_mod, only : prep_ice_get_mapper_SFo2i + use prep_glc_mod, only : prep_glc_get_mapper_Sl2g + use component_type_mod, only : atm, lnd, ice, ocn, rof, glc + ! + ! Arguments + type (seq_infodata_type) , intent(inout) :: infodata + logical , intent(in) :: rof_c2_ocn + logical , intent(in) :: samegrid_ao + logical , intent(in) :: samegrid_al + logical , intent(in) :: samegrid_ro + logical , intent(in) :: samegrid_lg ! lnd & glc on same grid + ! + ! Local variables + type(mct_gsmap), pointer :: gsmap_s, gsmap_d + type(mct_ggrid), pointer :: dom_s, dom_d + type(seq_map) , pointer :: mapper_Fa2o + type(seq_map) , pointer :: mapper_Sa2l + type(seq_map) , pointer :: mapper_SFo2i + type(seq_map) , pointer :: mapper_Sl2g + logical :: atm_present ! atm present flag + logical :: lnd_present ! lnd present flag + logical :: ocn_present ! ocn present flag + logical :: ice_present ! ice present flag + logical :: glc_present ! glc present flag + integer :: ka,km + character(*), parameter :: subname = '(component_init_aream)' + !--------------------------------------------------------------- + + ! Note that the following is assumed to hold - all gsmaps_cx for a given + ! instance of a component (e.g. atm(i)) are identical on the coupler processes + + mapper_Fa2o => prep_ocn_get_mapper_Fa2o() + mapper_Sa2l => prep_lnd_get_mapper_Sa2l() + mapper_SFo2i => prep_ice_get_mapper_SFo2i() + mapper_Sl2g => prep_glc_get_mapper_Sl2g() + + call seq_infodata_GetData( infodata, & + atm_present=atm_present, & + ocn_present=ocn_present, & + ice_present=ice_present, & + lnd_present=lnd_present, & + glc_present=glc_present) + + if (atm_present .and. ocn_present) then + if (samegrid_ao) then + dom_s => component_get_dom_cx(atm(1)) !dom_ax + dom_d => component_get_dom_cx(ocn(1)) !dom_ox + ka = mct_aVect_indexRa(dom_s%data, "area" ) + km = mct_aVect_indexRa(dom_s%data, "aream" ) + dom_s%data%rAttr(km,:) = dom_s%data%rAttr(ka,:) + + call seq_map_map(mapper_Fa2o, av_s=dom_s%data, av_d=dom_d%data, fldlist='aream') + else + gsmap_s => component_get_gsmap_cx(ocn(1)) ! gsmap_ox + gsmap_d => component_get_gsmap_cx(atm(1)) ! gsmap_ax + dom_s => component_get_dom_cx(ocn(1)) ! dom_ox + dom_d => component_get_dom_cx(atm(1)) ! dom_ax + + call seq_map_readdata('seq_maps.rc','ocn2atm_fmapname:', mpicom_CPLID, CPLID, & + gsmap_s=gsmap_s, av_s=dom_s%data, avfld_s='aream', filefld_s='area_a', & + gsmap_d=gsmap_d, av_d=dom_d%data, avfld_d='aream', filefld_d='area_b', & + string='ocn2atm aream initialization') + endif + end if + + if (ice_present .and. ocn_present) then + dom_s => component_get_dom_cx(ocn(1)) !dom_ox + dom_d => component_get_dom_cx(ice(1)) !dom_ix + + call seq_map_map(mapper_SFo2i, av_s=dom_s%data, av_d=dom_d%data, fldlist='aream') + endif + + if (rof_c2_ocn) then + if (.not.samegrid_ro) then + gsmap_s => component_get_gsmap_cx(rof(1)) ! gsmap_rx + dom_s => component_get_dom_cx(rof(1)) ! dom_rx + + call seq_map_readdata('seq_maps.rc', 'rof2ocn_liq_rmapname:',mpicom_CPLID, CPLID, & + gsmap_s=gsmap_s, av_s=dom_s%data, avfld_s='aream', filefld_s='area_a', & + string='rof2ocn liq aream initialization') + + call seq_map_readdata('seq_maps.rc', 'rof2ocn_ice_rmapname:',mpicom_CPLID, CPLID, & + gsmap_s=gsmap_s, av_s=dom_s%data, avfld_s='aream', filefld_s='area_a', & + string='rof2ocn ice aream initialization') + endif + end if + + if (lnd_present .and. atm_present) then + if (samegrid_al) then + dom_s => component_get_dom_cx(atm(1)) !dom_ax + dom_d => component_get_dom_cx(lnd(1)) !dom_lx + + call seq_map_map(mapper_Sa2l, av_s=dom_s%data, av_d=dom_d%data, fldlist='aream') + else + gsmap_d => component_get_gsmap_cx(lnd(1)) ! gsmap_lx + dom_d => component_get_dom_cx(lnd(1)) ! dom_lx + + call seq_map_readdata('seq_maps.rc','atm2lnd_fmapname:',mpicom_CPLID, CPLID, & + gsmap_d=gsmap_d, av_d=dom_d%data, avfld_d='aream', filefld_d='area_b', & + string='atm2lnd aream initialization') + endif + end if + + if (lnd_present .and. glc_present) then + if (samegrid_lg) then + dom_s => component_get_dom_cx(lnd(1)) !dom_lx + dom_d => component_get_dom_cx(glc(1)) !dom_gx + + call seq_map_map(mapper_Sl2g, av_s=dom_s%data, av_d=dom_d%data, fldlist='aream') + else + gsmap_d => component_get_gsmap_cx(glc(1)) ! gsmap_gx + dom_d => component_get_dom_cx(glc(1)) ! dom_gx + + call seq_map_readdata('seq_maps.rc','lnd2glc_fmapname:',mpicom_CPLID, CPLID, & + gsmap_d=gsmap_d, av_d=dom_d%data, avfld_d='aream', filefld_d='area_b', & + string='lnd2glc aream initialization') + endif + endif + + end subroutine component_init_aream + + !=============================================================================== + + subroutine component_init_areacor(comp, samegrid, seq_flds_c2x_fluxes) + !--------------------------------------------------------------- + ! COMPONENT PES and CPL/COMPONENT (for exchange only) + ! + ! Uses + use seq_domain_mct, only : seq_domain_areafactinit + ! + ! Arguments + type(component_type) , intent(inout) :: comp(:) + logical , intent(in) :: samegrid + character(len=*) , intent(in) :: seq_flds_c2x_fluxes + ! + ! Local Variables + integer :: eci, num_inst + character(*), parameter :: subname = '(component_init_areacor)' + !--------------------------------------------------------------- + + num_inst = size(comp) + do eci = 1,num_inst + + ! For joint cpl-component pes + if (comp(eci)%iamin_cplcompid) then + + ! Map component domain from coupler to component processes + call seq_map_map(comp(eci)%mapper_Cx2c, comp(eci)%dom_cx%data, & + comp(eci)%dom_cc%data, msgtag=comp(eci)%cplcompid*100+eci*10+5) + + ! For only component pes + if (comp(eci)%iamin_compid) then + + ! Allocate and initialize area correction factors on component processes + ! Note that the following call allocates comp(eci)%mld2drv(:) and comp(eci)%drv2mdl(:) + call seq_domain_areafactinit(comp(eci)%dom_cc, & + comp(eci)%mdl2drv, comp(eci)%drv2mdl, samegrid, & + comp(eci)%mpicom_compid, comp(eci)%iamroot_compid, & + 'areafact_'//comp(eci)%oneletterid//'_'//trim(comp(eci)%name)) + + ! Area correct component initialization output fields + call mct_avect_vecmult(comp(eci)%c2x_cc, comp(eci)%mdl2drv, seq_flds_c2x_fluxes, mask_spval=.true.) + + endif + + ! Map corrected initial component AVs from component to coupler pes + call seq_map_map(comp(eci)%mapper_cc2x, comp(eci)%c2x_cc, & + comp(eci)%c2x_cx, msgtag=comp(eci)%cplcompid*100+eci*10+7) + + endif + enddo + + end subroutine component_init_areacor + + !=============================================================================== + + subroutine component_run(Eclock, comp, comp_run, infodata, & + seq_flds_x2c_fluxes, seq_flds_c2x_fluxes, & + comp_prognostic, comp_num, timer_barrier, timer_comp_run, & + run_barriers, ymd, tod, comp_layout) + + !--------------------------------------------------------------- + ! Description + ! Run component model + ! Note that the optional arguments, seq_flds_x2c_fluxes and + ! seq_flds_c2x_fluxes, are not passed for external models (ESP) + ! since these type of models do not interact through the coupler. + ! The absence of these inputs should be used to avoid coupler- + ! based actions in component_run + ! + ! Arguments + type(ESMF_Clock) , intent(inout) :: EClock + type(component_type) , intent(inout) :: comp(:) + interface + subroutine comp_run( Eclock, cdata, x2c, c2x) + use ESMF, only : ESMF_Clock + use seq_cdata_mod, only : seq_cdata + use mct_mod, only : mct_avect + implicit none + type(ESMF_Clock), intent(inout) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2c + type(mct_aVect) , intent(inout) :: c2x + end subroutine comp_run + end interface + type (seq_infodata_type) , intent(inout) :: infodata + character(len=*) , intent(in), optional :: seq_flds_x2c_fluxes + character(len=*) , intent(in), optional :: seq_flds_c2x_fluxes + logical , intent(in) :: comp_prognostic + integer , intent(in), optional :: comp_num + character(len=*) , intent(in), optional :: timer_barrier + character(len=*) , intent(in), optional :: timer_comp_run + logical , intent(in), optional :: run_barriers + integer , intent(in), optional :: ymd ! Current date (YYYYMMDD) + integer , intent(in), optional :: tod ! Current time of day (seconds) + character(len=*) , intent(in), optional :: comp_layout + ! + ! Local Variables + integer :: eci + integer :: ierr + integer :: num_inst + real(r8) :: time_brun ! Start time + real(r8) :: time_erun ! Ending time + real(r8) :: cktime ! delta time + real(r8) :: cktime_acc(10) ! cktime accumulator array 1 = all, 2 = atm, etc + integer :: cktime_cnt(10) ! cktime counter array + logical :: seq_multi_inst ! a special case of running multiinstances on the same pes. + integer :: phase, phasemin, phasemax ! phase support + logical :: firstloop ! first time around phase loop + character(*), parameter :: subname = '(component_run:mct)' + !--------------------------------------------------------------- + + num_inst = size(comp) + seq_multi_inst = .false. + phasemin = 1 + phasemax = 1 + + if(present(comp_layout)) then + if(comp_layout .eq. "sequential" .and. num_inst > 1) then + seq_multi_inst=.true. + phasemin = 0 + endif + endif + + do phase = phasemin,phasemax + if (phase == phasemin) then + firstloop = .true. + else + firstloop = .false. + endif +#ifdef CPRPGI + if (comp(1)%oneletterid == 'a') call seq_infodata_putData(infodata, atm_phase=phase) + if (comp(1)%oneletterid == 'l') call seq_infodata_putData(infodata, lnd_phase=phase) + if (comp(1)%oneletterid == 'i') call seq_infodata_putData(infodata, ice_phase=phase) + if (comp(1)%oneletterid == 'o') call seq_infodata_putData(infodata, ocn_phase=phase) + if (comp(1)%oneletterid == 'r') call seq_infodata_putData(infodata, rof_phase=phase) + if (comp(1)%oneletterid == 'g') call seq_infodata_putData(infodata, glc_phase=phase) + if (comp(1)%oneletterid == 'w') call seq_infodata_putData(infodata, wav_phase=phase) + if (comp(1)%oneletterid == 'e') call seq_infodata_putData(infodata, esp_phase=phase) +#else + call seq_infodata_putData(comp(1)%oneletterid, infodata, comp_phase=phase) +#endif + + do eci = 1,num_inst + if (comp(eci)%iamin_compid) then + + if (present(timer_barrier)) then + if (present(run_barriers)) then + if (run_barriers) then + call t_drvstartf (trim(timer_barrier)) + call mpi_barrier(comp(eci)%mpicom_compid, ierr) + call t_drvstopf (trim(timer_barrier)) + time_brun = mpi_wtime() + endif + end if + end if + + if (present(timer_comp_run)) then + call t_drvstartf (trim(timer_comp_run), barrier=comp(eci)%mpicom_compid) + end if + if (drv_threading) call seq_comm_setnthreads(comp(1)%nthreads_compid) + + if (comp_prognostic .and. firstloop .and. present(seq_flds_x2c_fluxes)) then + call mct_avect_vecmult(comp(eci)%x2c_cc, comp(eci)%drv2mdl, seq_flds_x2c_fluxes, mask_spval=.true.) + end if + + call t_set_prefixf(comp(1)%oneletterid//":") + call comp_run(EClock, comp(eci)%cdata_cc, comp(eci)%x2c_cc, comp(eci)%c2x_cc) + if(nan_check_component_fields) then + call t_drvstartf ('check_fields') + call check_fields(comp(eci), eci) + call t_drvstopf ('check_fields') + endif + call t_unset_prefixf() + + if ((phase == 1) .and. present(seq_flds_c2x_fluxes)) then + call mct_avect_vecmult(comp(eci)%c2x_cc, comp(eci)%mdl2drv, seq_flds_c2x_fluxes, mask_spval=.true.) + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + if (present(timer_comp_run)) then + call t_drvstopf (trim(timer_comp_run)) + end if + + if (present(comp_num)) then + if (present(run_barriers)) then + if (run_barriers) then + time_erun = mpi_wtime() + cktime = time_erun - time_brun + cktime_acc(comp_num) = cktime_acc(comp_num) + cktime + cktime_cnt(comp_num) = cktime_cnt(comp_num) + 1 + if (present(ymd) .and. present(tod)) then + write(logunit,107) ' rstamp ',trim(comp(eci)%name), & + '_run_time: model date = ',ymd,tod, & + ' avg dt = ',cktime_acc(comp_num)/cktime_cnt(comp_num), & + ' dt = ',cktime, ' phase = ',phase + end if + endif + end if + end if + + endif + enddo ! eci + + enddo ! phase + +107 format( 3A, 2i8, A, f12.4, A, f12.4 ) + + end subroutine component_run + + !=============================================================================== + + subroutine component_final(Eclock, comp, comp_final) + + !--------------------------------------------------------------- + ! Description + ! Run component model + ! + ! Arguments + type(ESMF_Clock) , intent(inout) :: EClock + type(component_type) , intent(inout) :: comp(:) + interface + subroutine comp_final( Eclock, cdata, x2c, c2x) + use ESMF, only : ESMF_Clock + use seq_cdata_mod, only : seq_cdata + use mct_mod, only : mct_avect + implicit none + type(ESMF_Clock), intent(inout) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2c + type(mct_aVect) , intent(inout) :: c2x + end subroutine comp_final + end interface + ! + ! Local Variables + integer :: eci + integer :: num_inst + character(*), parameter :: subname = '(component_final:mct)' + !--------------------------------------------------------------- + + num_inst = size(comp) + do eci = 1,num_inst + if (comp(eci)%iamin_compid) then + if (drv_threading) call seq_comm_setnthreads(comp(1)%nthreads_compid) + call t_set_prefixf(comp(1)%oneletterid//"_f:") + call comp_final(EClock, comp(eci)%cdata_cc, comp(eci)%x2c_cc, comp(eci)%c2x_cc) + call t_unset_prefixf() + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + end if + end do + + end subroutine component_final + + !=============================================================================== + + subroutine component_exch(comp, flow, infodata, infodata_string, & + mpicom_barrier, run_barriers, & + timer_barrier, timer_comp_exch, timer_map_exch, timer_infodata_exch) + + !--------------------------------------------------------------- + ! Description + ! Map x2m_mx to x2m_mm (component input av from + ! coupler processes to component model processes) + ! + ! Arguments + implicit none + type(component_type) , intent(inout) :: comp(:) + character(len=3) , intent(in) :: flow + type(seq_infodata_type) , intent(inout) :: infodata + character(len=*) , intent(in) :: infodata_string + integer , intent(in), optional :: mpicom_barrier ! mpicom for barrier call + logical , intent(in), optional :: run_barriers + character(len=*) , intent(in), optional :: timer_barrier ! timer + character(len=*) , intent(in), optional :: timer_comp_exch + character(len=*) , intent(in), optional :: timer_map_exch + character(len=*) , intent(in), optional :: timer_infodata_exch + ! + ! Local Variables + integer :: eci + integer :: ierr + character(*), parameter :: subname = '(component_exch)' + !--------------------------------------------------------------- + + if (present(timer_barrier)) then + if (run_barriers) then + call t_drvstartf (trim(timer_barrier)) + call mpi_barrier(comp(1)%mpicom_cplallcompid,ierr) + call t_drvstopf (trim(timer_barrier)) + endif + end if + + if (present(timer_comp_exch)) then + if (present(mpicom_barrier)) then + call t_drvstartf (trim(timer_comp_exch), cplcom=.true., barrier=mpicom_barrier) + end if + end if + + do eci = 1,size(comp) + if (comp(eci)%iamin_cplcompid) then + if (present(timer_map_exch)) then + call t_drvstartf (trim(timer_map_exch), barrier=comp(eci)%mpicom_cplcompid) + end if + + if (flow == 'x2c') then ! coupler to component + call seq_map_map(comp(eci)%mapper_Cx2c, comp(eci)%x2c_cx, comp(eci)%x2c_cc, & + msgtag=comp(eci)%cplcompid*100+eci*10+2) + else if (flow == 'c2x') then ! component to coupler + call seq_map_map(comp(eci)%mapper_Cc2x, comp(eci)%c2x_cc, comp(eci)%c2x_cx, & + msgtag=comp(eci)%cplcompid*100+eci*10+4) + end if + + if (present(timer_map_exch)) then + call t_drvstopf (trim(timer_map_exch)) + end if + endif + enddo + + if (present(timer_infodata_exch)) then + call t_drvstartf (trim(timer_infodata_exch), barrier=mpicom_barrier) + end if + if (flow == 'c2x') then + if (comp(1)%iamin_cplcompid) then + call seq_infodata_exchange(infodata, comp(1)%cplcompid, trim(infodata_string)) + end if + else if (flow == 'x2c') then + if (comp(1)%iamin_cplallcompid) then + call seq_infodata_exchange(infodata, comp(1)%cplallcompid, trim(infodata_string)) + end if + endif + if (present(timer_infodata_exch)) then + call t_drvstopf (trim(timer_infodata_exch)) + end if + + if (present(timer_comp_exch)) then + if (present(mpicom_barrier)) then + call t_drvstopf (trim(timer_comp_exch), cplcom=.true.) + end if + end if + + end subroutine component_exch + + !=============================================================================== + + subroutine component_diag(infodata, comp, flow, comment, info_debug, timer_diag ) + + !--------------------------------------------------------------- + ! Description + ! Component diagnostics for send/recv to coupler + ! + ! Arguments + type (seq_infodata_type) , intent(inout) :: infodata + type(component_type) , intent(in) :: comp(:) + character(len=3) , intent(in) :: flow + character(len=*) , intent(in) :: comment + integer , intent(in) :: info_debug + character(len=*) , intent(in), optional :: timer_diag + ! + ! Local Variables + integer :: eci + character(*), parameter :: subname = '(component_diag)' + !--------------------------------------------------------------- + + if (info_debug > 1) then + if (present(timer_diag)) then + call t_drvstartf (trim(timer_diag), barrier=mpicom_CPLID) + end if + + do eci = 1,size(comp) + if (flow == 'x2c') then ! coupler to component + call seq_diag_avect_mct(infodata, CPLID, comp(eci)%x2c_cx, & + comp(eci)%dom_cx, comp(eci)%gsmap_cx, trim(comment)//comp(eci)%suffix) + end if + if (flow == 'c2x') then ! component to coupler + call seq_diag_avect_mct(infodata, CPLID, comp(eci)%c2x_cx, & + comp(eci)%dom_cx, comp(eci)%gsmap_cx, trim(comment)//comp(eci)%suffix) + end if + enddo + + if (present(timer_diag)) then + call t_drvstopf (trim(timer_diag)) + end if + endif + + end subroutine component_diag + +end module component_mod diff --git a/driver-mct/main/component_type_mod.F90 b/driver-mct/main/component_type_mod.F90 new file mode 100644 index 000000000000..50bad3c021e5 --- /dev/null +++ b/driver-mct/main/component_type_mod.F90 @@ -0,0 +1,265 @@ +module component_type_mod + + !---------------------------------------------------------------------------- + ! share code & libs + !---------------------------------------------------------------------------- + use shr_kind_mod , only: r8 => SHR_KIND_R8 + use shr_kind_mod , only: cs => SHR_KIND_CS + use shr_kind_mod , only: cl => SHR_KIND_CL + use shr_kind_mod , only: IN => SHR_KIND_IN + use seq_cdata_mod , only: seq_cdata + use seq_map_type_mod , only: seq_map + use seq_comm_mct , only: seq_comm_namelen + use seq_comm_mct , only: num_inst_atm, num_inst_lnd, num_inst_rof + use seq_comm_mct , only: num_inst_ocn, num_inst_ice, num_inst_glc + use seq_comm_mct , only: num_inst_wav, num_inst_esp + use mct_mod + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + ! + ! on component pes + public :: component_get_c2x_cc + public :: component_get_x2c_cc + public :: component_get_dom_cc + public :: component_get_gsmap_cc + public :: component_get_cdata_cc + public :: component_get_iamroot_compid + public :: check_fields + ! + ! on cpl pes + public :: component_get_x2c_cx + public :: component_get_c2x_cx + public :: component_get_dom_cx + public :: component_get_gsmap_cx + public :: component_get_drv2mdl + public :: component_get_mdl2drv + ! + ! on union coupler/component pes + public :: component_get_mapper_Cc2x + public :: component_get_mapper_Cx2c + ! + ! on driver pes (all pes) + public :: component_get_name + public :: component_get_suffix + public :: component_get_iamin_compid + + !-------------------------------------------------------------------------- + ! Public data + !-------------------------------------------------------------------------- + + type component_type + ! + ! Coupler pes + ! used by prep_xxx and all other coupler based routines + ! + type(mct_ggrid) , pointer :: dom_cx => null() ! component domain (same for all instances) + type(mct_gsMap) , pointer :: gsMap_cx => null() ! decomposition on coupler pes (same for all instances) + type(mct_aVect) , pointer :: x2c_cx => null() ! + type(mct_aVect) , pointer :: c2x_cx => null() + ! + ! Component pes + ! + type(seq_cdata) , pointer :: cdata_cc => null() + type(mct_ggrid) , pointer :: dom_cc => null() + type(mct_gsMap) , pointer :: gsMap_cc => null() ! decomposition on component pes + type(mct_aVect) , pointer :: x2c_cc => null() + type(mct_aVect) , pointer :: c2x_cc => null() + real(r8) , pointer :: drv2mdl(:) => null() ! area correction factors + real(r8) , pointer :: mdl2drv(:) => null() ! area correction factors + ! + ! Union of coupler/component pes - used by exchange routines + ! + type(seq_map) , pointer :: mapper_Cc2x => null() ! coupler -> component rearranging + type(seq_map) , pointer :: mapper_Cx2c => null() ! component -> coupler rearranging + ! + ! Driver pes (all pes) + ! + integer :: compid + integer :: cplcompid + integer :: cplallcompid + integer :: mpicom_compid + integer :: mpicom_cplcompid + integer :: mpicom_cplallcompid + logical :: iamin_compid + logical :: iamin_cplcompid + logical :: iamin_cplallcompid + logical :: iamroot_compid + logical :: present ! true => component is present and not stub + integer :: nthreads_compid + integer :: instn + character(len=CL) :: suffix + character(len=1) :: oneletterid + character(len=3) :: ntype + character(len=seq_comm_namelen) :: name + end type component_type + + public :: component_type + + !---------------------------------------------------------------------------- + ! Component type instances + !---------------------------------------------------------------------------- + + type(component_type), target :: atm(num_inst_atm) + type(component_type), target :: lnd(num_inst_lnd) + type(component_type), target :: rof(num_inst_rof) + type(component_type), target :: ocn(num_inst_ocn) + type(component_type), target :: ice(num_inst_ice) + type(component_type), target :: glc(num_inst_glc) + type(component_type), target :: wav(num_inst_wav) + type(component_type), target :: esp(num_inst_esp) + + public :: atm, lnd, rof, ocn, ice, glc, wav, esp + + !=============================================================================== + +contains + + !=============================================================================== + ! Accessor functions into component instance + !=============================================================================== + + function component_get_c2x_cc(comp) + type(component_type), intent(in), target :: comp + type(mct_avect), pointer :: component_get_c2x_cc + component_get_c2x_cc => comp%c2x_cc + end function component_get_c2x_cc + + function component_get_c2x_cx(comp) + type(component_type), intent(in), target :: comp + type(mct_avect), pointer :: component_get_c2x_cx + component_get_c2x_cx => comp%c2x_cx + end function component_get_c2x_cx + + function component_get_x2c_cc(comp) + type(component_type), intent(in), target :: comp + type(mct_avect), pointer :: component_get_x2c_cc + component_get_x2c_cc => comp%x2c_cc + end function component_get_x2c_cc + + function component_get_x2c_cx(comp) + type(component_type), intent(in), target :: comp + type(mct_avect), pointer :: component_get_x2c_cx + component_get_x2c_cx => comp%x2c_cx + end function component_get_x2c_cx + + function component_get_name(comp) + type(component_type), intent(in), target :: comp + character(len=CL) :: component_get_name + component_get_name = comp%name + end function component_get_name + + function component_get_iamin_compid(comp) + type(component_type), intent(in), target :: comp + logical :: component_get_iamin_compid + component_get_iamin_compid = comp%iamin_compid + end function component_get_iamin_compid + + function component_get_iamroot_compid(comp) + type(component_type), intent(in), target :: comp + logical :: component_get_iamroot_compid + component_get_iamroot_compid = comp%iamroot_compid + end function component_get_iamroot_compid + + function component_get_suffix(comp) + type(component_type), intent(in), target :: comp + character(len=CL) :: component_get_suffix + component_get_suffix = comp%suffix + end function component_get_suffix + + function component_get_dom_cx(comp) + type(component_type), intent(in), target :: comp + type(mct_ggrid), pointer :: component_get_dom_cx + component_get_dom_cx => comp%dom_cx + end function component_get_dom_cx + + function component_get_dom_cc(comp) + type(component_type), intent(in), target :: comp + type(mct_ggrid), pointer :: component_get_dom_cc + component_get_dom_cc => comp%dom_cc + end function component_get_dom_cc + + function component_get_gsmap_cx(comp) + type(component_type), intent(in), target :: comp + type(mct_gsmap), pointer :: component_get_gsmap_cx + component_get_gsmap_cx => comp%gsmap_cx + end function component_get_gsmap_cx + + function component_get_gsmap_cc(comp) + type(component_type), intent(in), target :: comp + type(mct_gsmap), pointer :: component_get_gsmap_cc + component_get_gsmap_cc => comp%gsmap_cc + end function component_get_gsmap_cc + + function component_get_cdata_cc(comp) + type(component_type), intent(in), target :: comp + type(seq_cdata), pointer :: component_get_cdata_cc + component_get_cdata_cc => comp%cdata_cc + end function component_get_cdata_cc + + function component_get_drv2mdl(comp) + type(component_type), intent(in), target :: comp + real(r8), pointer :: component_get_drv2mdl(:) + component_get_drv2mdl => comp%drv2mdl + end function component_get_drv2mdl + + function component_get_mdl2drv(comp) + type(component_type), intent(in), target :: comp + real(r8), pointer :: component_get_mdl2drv(:) + component_get_mdl2drv => comp%mdl2drv + end function component_get_mdl2drv + + function component_get_mapper_Cc2x(comp) + type(component_type), intent(in), target :: comp + type(seq_map), pointer :: component_get_mapper_Cc2x + component_get_mapper_Cc2x => comp%mapper_Cc2x + end function component_get_mapper_Cc2x + + function component_get_mapper_Cx2c(comp) + type(component_type), intent(in), target :: comp + type(seq_map), pointer :: component_get_mapper_Cx2c + component_get_mapper_Cx2c => comp%mapper_Cx2c + end function component_get_mapper_Cx2c + + subroutine check_fields(comp, comp_index) + use shr_infnan_mod, only: shr_infnan_isnan + use mct_mod, only: mct_avect_getrlist2c, mct_gsMap_orderedPoints + type(component_type), intent(in) :: comp + integer(in), intent(in) :: comp_index + + integer(IN) :: lsize ! size of attr vect + integer(IN) :: nflds ! number of attr vects + integer(in) :: fld, n ! iterators + integer(IN) :: rank + integer(IN) :: ierr + integer(IN), pointer :: gpts(:) + character(len=CL) :: msg + + if(associated(comp%c2x_cc) .and. associated(comp%c2x_cc%rattr)) then + lsize = mct_avect_lsize(comp%c2x_cc) + nflds = size(comp%c2x_cc%rattr,1) + ! c2x_cc is allocated even if not used such as in stub models + ! do not test this case. + if(lsize <= 1 .and. nflds <= 1) return + if(any(shr_infnan_isnan(comp%c2x_cc%rattr))) then + do fld=1,nflds + do n=1,lsize + if(shr_infnan_isnan(comp%c2x_cc%rattr(fld,n))) then + call mpi_comm_rank(comp%mpicom_compid, rank, ierr) + call mct_gsMap_orderedPoints(comp%gsmap_cc, rank, gpts) + write(msg,'(a,a,a,i4,a,a,a,i8)')'component_mod:check_fields NaN found in ',trim(comp%name),' instance: ',& + comp_index,' field ',trim(mct_avect_getRList2c(fld, comp%c2x_cc)), ' 1d global index: ',gpts(n) + call shr_sys_abort(msg) + endif + enddo + enddo + endif + endif + end subroutine check_fields + +end module component_type_mod diff --git a/driver-mct/main/cplcomp_exchange_mod.F90 b/driver-mct/main/cplcomp_exchange_mod.F90 new file mode 100644 index 000000000000..148ab57fa735 --- /dev/null +++ b/driver-mct/main/cplcomp_exchange_mod.F90 @@ -0,0 +1,965 @@ +module cplcomp_exchange_mod + + use shr_kind_mod, only: R8 => SHR_KIND_R8, IN=>SHR_KIND_IN + use shr_kind_mod, only: CL => SHR_KIND_CL, CX => SHR_KIND_CX, CXX => SHR_KIND_CXX + use shr_sys_mod + use shr_const_mod + use shr_mct_mod, only: shr_mct_sMatPInitnc, shr_mct_queryConfigFile + use mct_mod + use seq_map_type_mod + use component_type_mod + use seq_flds_mod, only: seq_flds_dom_coord, seq_flds_dom_other + use seq_comm_mct, only: cplid, logunit + use seq_comm_mct, only: seq_comm_getinfo => seq_comm_setptrs, seq_comm_iamin + use seq_diag_mct + + implicit none + private ! except +#include + save + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: seq_map_init_exchange ! union of cpl/component pes + public :: seq_map_map_exchange ! union of cpl/component pes + public :: seq_mctext_gsmapInit + public :: seq_mctext_avInit + public :: seq_mctext_gGridInit + public :: seq_mctext_avExtend + +!-------------------------------------------------------------------------- +! Private interfaces +!-------------------------------------------------------------------------- + + ! Shared routines for extension and computation of gsmaps, avs, and ggrids + private :: seq_mctext_gsmapIdentical + private :: seq_mctext_gsmapExtend + private :: seq_mctext_gsmapCreate + private :: seq_mctext_avCreate + +!-------------------------------------------------------------------------- +! Public data +!-------------------------------------------------------------------------- + + integer,public :: seq_mctext_decomp + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + character(*),parameter :: subName = '(seq_mctext_mct)' + real(r8),parameter :: c1 = 1.0_r8 + + !======================================================================= +contains + !======================================================================= + + subroutine seq_map_init_exchange( comp, mapper, flow, string) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(component_type), intent(inout) :: comp + type(seq_map) , intent(inout), pointer :: mapper + character(len=3), intent(in) :: flow + character(len=*), intent(in),optional :: string + ! + ! Local Variables + ! + integer(IN) :: ID_s + integer(IN) :: ID_d + integer(IN) :: ID_join + integer(IN) :: mapid, mapidmin, mapidmax + integer(IN) :: mpicom_s, mpicom_d, mpicom_join + type(mct_gsmap) , pointer :: gsmap_s + type(mct_gsmap) , pointer :: gsmap_d + type(mct_gsmap) :: gsmap_s_join + type(mct_gsmap) :: gsmap_d_join + character(len=*),parameter :: subname = "(seq_map_init_rearrsplit) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + endif + + id_join = comp%cplcompid + call seq_comm_getinfo(ID_join, mpicom=mpicom_join) + + if (flow == 'c2x') then + gsmap_s => component_get_gsmap_cc(comp) + gsmap_d => component_get_gsmap_cx(comp) + end if + if (flow == 'x2c') then + gsmap_s => component_get_gsmap_cx(comp) + gsmap_d => component_get_gsmap_cc(comp) + end if + + if (mct_gsmap_Identical(gsmap_s,gsmap_d)) then + + call seq_map_mapmatch(mapid, gsmap_s=gsmap_s, gsmap_d=gsmap_d, strategy="copy") + + if (mapid > 0) then + call seq_map_mappoint(mapid, mapper) + else + call seq_map_mapinit(mapper, mpicom_join) + mapper%copy_only = .true. + mapper%strategy = "copy" + if (flow == 'c2x') then + mapper%gsmap_s => component_get_gsmap_cc(comp) + mapper%gsmap_d => component_get_gsmap_cx(comp) + end if + if (flow == 'x2c') then + mapper%gsmap_s => component_get_gsmap_cx(comp) + mapper%gsmap_d => component_get_gsmap_cc(comp) + end if + endif + + if (seq_comm_iamroot(ID_join)) then + write(logunit,'(2A,L2)') subname,' gsmaps ARE IDENTICAL, copyoption = ',mapper%copy_only + endif + + else + + if (seq_comm_iamroot(ID_join)) write(logunit,'(2A)') subname,' gsmaps are not identical' + + if (flow == 'c2x') then + id_s = comp%compid + id_d = cplid + end if + if (flow == 'x2c') then + id_s = cplid + id_d = comp%compid + end if + call seq_comm_getinfo(ID_s , mpicom=mpicom_s) + call seq_comm_getinfo(ID_d , mpicom=mpicom_d) + call seq_comm_getinfo(ID_join, mpicom=mpicom_join) + + ! --- Extend gsmaps to join group of pes + + call seq_mctext_gsmapExtend(gsmap_s, mpicom_s, gsmap_s_join, mpicom_join, ID_join) + call seq_mctext_gsmapExtend(gsmap_d, mpicom_d, gsmap_d_join, mpicom_join, ID_join) + + ! --- Initialize rearranger based on join gsmaps + ! --- test for the gsmaps instead of the gsmap joins because the gsmap joins are temporary + + ! ------------------------------- + ! tcx tcraig mapmatch is a problem here because we're comparing gsmaps that may not be defined + ! on some pes. first issue is whether gsmap_identical in underlying routine will abort. + ! second issue is whether different pes return different values. use mapidmin, mapidmax to + ! confirm all mapids returned are the same. if not, then just set mapid to -1 and compute + ! a new rearranger. + ! tcx not clear this works all the time, so just do not do map matching here for time being + ! Sept 2013. + ! ------------------------------- + ! mapid = -1 + ! call seq_map_mapmatch(mapid,gsmap_s=gsmap_s,gsmap_d=gsmap_d,strategy="rearrange") + ! call shr_mpi_min(mapid,mapidmin,mpicom_join,subname//' min') + ! call shr_mpi_max(mapid,mapidmax,mpicom_join,subname//' max') + ! if (mapidmin /= mapidmax) mapid = -1 + ! ------------------------------- + + ! --- Initialize rearranger + ! --- the gsmap joins are temporary so store the regular gsmaps in the mapper + call seq_map_mapinit(mapper, mpicom_join) + mapper%rearrange_only = .true. + mapper%strategy = "rearrange" + if (flow == 'c2x') then + mapper%gsmap_s => component_get_gsmap_cc(comp) + mapper%gsmap_d => component_get_gsmap_cx(comp) + end if + if (flow == 'x2c') then + mapper%gsmap_s => component_get_gsmap_cx(comp) + mapper%gsmap_d => component_get_gsmap_cc(comp) + end if + call seq_map_gsmapcheck(gsmap_s_join, gsmap_d_join) + call mct_rearr_init(gsmap_s_join, gsmap_d_join, mpicom_join, mapper%rearr) + + ! --- Clean up temporary gsmaps + + call mct_gsMap_clean(gsmap_s_join) + call mct_gsMap_clean(gsmap_d_join) + + endif + + if (seq_comm_iamroot(CPLID)) then + write(logunit,'(2A,I6,4A)') subname,' mapper counter, strategy, mapfile = ', & + mapper%counter,' ',trim(mapper%strategy),' ',trim(mapper%mapfile) + call shr_sys_flush(logunit) + endif + + end subroutine seq_map_init_exchange + + !=============================================================================== + + subroutine seq_map_map_exchange( comp, flow, dom_flag, dom_tmp, string, msgtag ) + + !----------------------------------------------------- + ! + ! Arguments + ! + type(component_type) , intent(inout) :: comp + character(len=3) , intent(in) :: flow + logical , intent(in),optional :: dom_flag + type(mct_gGrid) , intent(in),optional, target :: dom_tmp + character(len=*) , intent(in),optional :: string + integer(IN) , intent(in),optional :: msgtag + ! + ! Local Variables + ! + type(seq_map) , pointer :: mapper + type(mct_aVect), pointer :: av_s + type(mct_aVect), pointer :: av_d + type(mct_gGrid), pointer :: dom_s + type(mct_gGrid), pointer :: dom_d + integer(IN),save :: ltag ! message tag for rearrange + character(len=*),parameter :: subname = "(seq_map_map) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + endif + + if (flow == 'c2x') then + if (present(dom_flag)) then + dom_s => component_get_dom_cc(comp) + dom_d => component_get_dom_cx(comp) + ! Overwrite dom_d pointer if dom_tmp is present + ! Needed for backwards compatibility with domain checker in component_init_cx + if (present(dom_tmp)) then + dom_d => dom_tmp + end if + else + av_s => component_get_c2x_cc(comp) + av_d => component_get_c2x_cx(comp) + end if + mapper => component_get_mapper_Cc2x(comp) + end if + if (flow == 'x2c') then + if (present(dom_flag)) then + dom_s => component_get_dom_cx(comp) + dom_d => component_get_dom_cc(comp) + else + av_s => component_get_x2c_cx(comp) + av_d => component_get_x2c_cc(comp) + end if + mapper => component_get_mapper_Cx2c(comp) + end if + + if (present(msgtag)) then + ltag = msgtag + else + ltag = 2000 + endif + + if (mapper%copy_only) then + !------------------------------------------- + ! COPY data + !------------------------------------------- + if (present(dom_flag)) then + call mct_aVect_copy(aVin=dom_s%data, aVout=dom_d%data, vector=mct_usevector) + else + call mct_aVect_copy(aVin=av_s, aVout=av_d, vector=mct_usevector) + end if + + else if (mapper%rearrange_only) then + !------------------------------------------- + ! REARRANGE data + !------------------------------------------- + if (present(dom_flag)) then + call mct_rearr_rearrange(dom_s%data, dom_d%data, mapper%rearr, tag=ltag, VECTOR=mct_usevector, & + ALLTOALL=mct_usealltoall) + else + call mct_rearr_rearrange(av_s, av_d, mapper%rearr, tag=ltag, VECTOR=mct_usevector, & + ALLTOALL=mct_usealltoall) + end if + end if + + end subroutine seq_map_map_exchange + + !======================================================================= + + subroutine seq_mctext_gsmapInit(comp) + + ! This routine initializes a gsmap based on another gsmap potentially + ! on other pes. It addresses non-overlap of pes. + + !----------------------------------------------------- + ! + ! Arguments + ! + type(component_type), intent(inout) :: comp + ! + ! Local Variables + ! + integer :: mpicom_cplid + integer :: mpicom_old + integer :: mpicom_new + integer :: mpicom_join + integer :: ID_old + integer :: ID_new + integer :: ID_join + type(mct_gsMap), pointer :: gsmap_old + type(mct_gsMap), pointer :: gsmap_new + type(mct_gsMap) :: gsmap_old_join ! gsmap_old on joined id, temporary + character(len=*),parameter :: subname = "(seq_mctext_gsmapInit) " + !----------------------------------------------------- + + call seq_comm_getinfo(CPLID, mpicom=mpicom_CPLID) + + id_new = cplid + id_old = comp%compid + id_join = comp%cplcompid + + mpicom_new = mpicom_cplid + mpicom_old = comp%mpicom_compid + mpicom_join = comp%mpicom_cplcompid + + gsmap_new => component_get_gsmap_cx(comp) + gsmap_old => component_get_gsmap_cc(comp) + + call seq_comm_getinfo(ID_old ,mpicom=mpicom_old) + call seq_comm_getinfo(ID_new ,mpicom=mpicom_new) + call seq_comm_getinfo(ID_join,mpicom=mpicom_join) + + ! --- Set gsmaps + ! --- Extend the old one to now span all pes on ID_join + ! --- Create a new gsmap on pes associated with ID_new using info from the old one + + call seq_mctext_gsmapExtend(gsmap_old , mpicom_old , gsmap_old_join, mpicom_join, ID_join) + call seq_mctext_gsmapCreate(gsmap_old_join, mpicom_join , gsmap_new , mpicom_new , ID_new ) + + call mct_gsMap_clean(gsmap_old_join) + + end subroutine seq_mctext_gsmapInit + + !======================================================================= + + subroutine seq_mctext_avInit( comp, flow ) + + !----------------------------------------------------- + ! This routine initializes Avs that may need to be extended + ! + ! Arguments + ! + type(component_type), intent(inout) :: comp + character(len=3) , intent(in) :: flow + ! + ! Local Variables + ! + integer :: lsize + integer :: mpicom_cplid + integer :: mpicom_new + integer :: ID_old + integer :: ID_new + integer :: ID_join + type(mct_aVect), pointer :: AV1_old + type(mct_aVect), pointer :: AV1_new + type(mct_gsmap), pointer :: gsmap_new + character(len=*),parameter :: subname = "(seq_mctext_avInit) " + !----------------------------------------------------- + + ! --- Setup data for use and make sure the old ID is ok + + call seq_comm_getinfo(CPLID ,mpicom=mpicom_CPLID) + + id_new = cplid + id_old = comp%compid + id_join = comp%cplcompid + + mpicom_new = mpicom_cplid + + gsmap_new => component_get_gsmap_cx(comp) + + if (flow == 'c2x') then + av1_old => component_get_c2x_cc(comp) + av1_new => component_get_c2x_cx(comp) + end if + if (flow == 'x2c') then + av1_old => component_get_x2c_cc(comp) + av1_new => component_get_x2c_cx(comp) + end if + + ! --- Extend old avs and initialize new avs for use in the future + + lsize = 0 + if (seq_comm_iamin(ID_new)) then + lsize = mct_gsMap_lsize(gsMap_new, mpicom_new) + endif + call seq_mctext_avExtend(AV1_old, ID_old, ID_join) + call seq_mctext_avCreate(AV1_old, ID_old, AV1_new, ID_join, lsize) + + end subroutine seq_mctext_avInit + + !======================================================================= + + subroutine seq_mctext_gGridInit(comp, ggrid_new) + + !----------------------------------------------------- + ! This routine initializes gGrids that may need to be extended + ! + ! Arguments + ! + type(component_type), intent(inout) :: comp + type(mct_gGrid), optional, target, intent(inout) :: ggrid_new + ! + ! Local Variables + ! + integer :: mpicom_cplid + integer :: lsize + integer :: mpicom_new + integer :: ID_old + integer :: ID_new + integer :: ID_join + type(mct_gGrid), pointer :: GG1_old + type(mct_gGrid), pointer :: GG1_new + type(mct_gsmap), pointer :: gsmap_new + character(len=*),parameter :: subname = "(seq_mctext_gGridInit) " + !----------------------------------------------------- + + ! --- Setup data for use and make sure the old ID is ok + + call seq_comm_getinfo(CPLID, mpicom=mpicom_CPLID) + + id_new = cplid + id_old = comp%compid + id_join = comp%cplcompid + + mpicom_new = mpicom_cplid + + gsmap_new => component_get_gsmap_cx(comp) + + gg1_old => component_get_dom_cc(comp) + gg1_new => component_get_dom_cx(comp) + + ! --- Extend old ggrids and initialize new ggrids for use in the future + + lsize = 0 + if (seq_comm_iamin(ID_new)) then + lsize = mct_gsMap_lsize(gsMap_new,mpicom_new) + endif + call seq_mctext_avExtend(GG1_old%data, ID_old, ID_join) + + if (present(ggrid_new)) then + call mct_gGrid_init(GGrid=ggrid_new, CoordChars=seq_flds_dom_coord, OtherChars=seq_flds_dom_other, lsize=lsize ) + call mct_avect_zero(ggrid_new%data) + else + call mct_gGrid_init(GGrid=GG1_new, CoordChars=seq_flds_dom_coord, OtherChars=seq_flds_dom_other, lsize=lsize ) + call mct_avect_zero(GG1_new%data) + end if + + end subroutine seq_mctext_gGridInit + + !======================================================================= + + subroutine seq_mctext_gsmapExtend(gsmapi, mpicomi, gsmapo, mpicomo, compido) + + !---------------------------------------------------------------- + ! Extend/Convert a gsmap from one mpicom to another mpicom that contains + ! at least all the pes that gsmap uses, but with different ranks + !---------------------------------------------------------------- + + implicit none + type(mct_gsMap), intent(IN) :: gsmapi + integer , intent(IN) :: mpicomi + type(mct_gsMap), intent(OUT):: gsmapo + integer , intent(IN) :: mpicomo + integer , intent(IN) :: compido + + character(len=*),parameter :: subname = "(seq_mctext_gsmapExtend) " + integer :: n + integer :: ngseg + integer :: gsize + integer :: msizei,msizeo + integer :: mrank,mranko,mrankog ! sets pe rank of root mpicomi pe in mpicomo + integer :: mpigrpi,mpigrpo + integer :: ierr + integer, pointer :: pei(:),peo(:) + integer, pointer :: start(:),length(:),peloc(:) + + mranko = -1 + + ! --- create the new gsmap on the mpicomi root only + + if (mpicomi /= MPI_COMM_NULL) then + call mpi_comm_rank(mpicomi,mrank,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_comm_rank i') + if (mrank == 0) then + call mpi_comm_group(mpicomi,mpigrpi,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_comm_group i') + call mpi_comm_group(mpicomo,mpigrpo,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_comm_group o') + call mpi_comm_size(mpicomi,msizei,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_comm_size i') + call mpi_comm_size(mpicomo,msizeo,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_comm_size o') + + ! --- setup the translation of pe numbers from the old gsmap(mpicom) + ! --- to the new one, pei -> peo + + allocate(pei(0:msizei-1),peo(0:msizei-1)) + do n = 0,msizei-1 + pei(n) = n + enddo + + peo = -1 + call mpi_group_translate_ranks(mpigrpi,msizei,pei,mpigrpo,peo,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_group_translate_ranks') + + do n = 0,msizei-1 + if (peo(n) < 0 .or. peo(n) > msizeo-1) then + write(logunit,*) subname,' peo out of bounds ',peo(n),msizeo + call shr_sys_abort() + endif + enddo + + mranko = peo(0) + + ! --- compute the new gsmap which has the same start and length values + ! --- but peloc is now the mapping of pei to peo + + ngseg = gsmapi%ngseg + gsize = gsmapi%gsize + allocate(start(ngseg),length(ngseg),peloc(ngseg)) + do n = 1,ngseg + start(n) = gsmapi%start(n) + length(n) = gsmapi%length(n) + peloc(n) = peo(gsmapi%pe_loc(n)) + enddo + + ! --- initialize the gsmap on the root pe + + call mct_gsmap_init(gsmapo,compido,ngseg,gsize,start,length,peloc) + + deallocate(pei,peo,start,length,peloc) + endif + endif + + ! --- broadcast via allreduce the mpicomi root pe in mpicomo space + ! --- mranko is -1 except on the root pe where is it peo of that pe + + call mpi_allreduce(mranko,mrankog,1,MPI_INTEGER,MPI_MAX,mpicomo,ierr) + call shr_mpi_chkerr(ierr,subname//' gsm_cop mpi_allreduce max') + + ! --- broadcast the gsmap to all pes in mpicomo from mrankog + + call mct_gsmap_bcast(gsmapo, mrankog, mpicomo) + + ! tcx summarize decomp info +#if (1 == 0) + write(logunit,*) trim(subname),'tcxa ',mpicomi,mpicomo + call shr_sys_flush(logunit) + call mpi_barrier(mpicomo,ierr) + + if (mpicomi /= MPI_COMM_NULL) then + call mpi_comm_rank(mpicomi,mrank,ierr) + write(logunit,*) 'tcxbi ',mrank + if (mrank == 0) then + write(logunit,*) 'tcxci ',gsmapi%ngseg,size(gsmapi%start),gsmapi%gsize,gsmapi%comp_id + do n = 1,gsmapi%ngseg + write(logunit,*) 'tcx gsmti ',n,gsmapi%start(n),gsmapi%length(n),gsmapi%pe_loc(n) + enddo + call shr_sys_flush(logunit) + endif + endif + + if (mpicomo /= MPI_COMM_NULL) then + call mpi_comm_rank(mpicomo,mrank,ierr) + write(logunit,*) 'tcxbo ',mrank + if (mrank == 0) then + write(logunit,*) 'tcxco ',gsmapo%ngseg,size(gsmapo%start),gsmapo%gsize,gsmapo%comp_id + do n = 1,gsmapo%ngseg + write(logunit,*) 'tcx gsmto ',n,gsmapo%start(n),gsmapo%length(n),gsmapo%pe_loc(n) + enddo + call shr_sys_flush(logunit) + endif + endif + + call shr_sys_flush(logunit) + call mpi_barrier(mpicomo,ierr) +#endif + + + end subroutine seq_mctext_gsmapExtend + + !======================================================================= + + subroutine seq_mctext_gsmapCreate(gsmapi, mpicomi, gsmapo, mpicomo, compido) + + !--------------------------------------------------------------------- + ! creates a new gsmap on a subset of pes, requires setting a new decomp + !--------------------------------------------------------------------- + + implicit none + type(mct_gsMap), intent(IN) :: gsmapi + integer , intent(IN) :: mpicomi + type(mct_gsMap), intent(OUT):: gsmapo + integer , intent(IN) :: mpicomo + integer , intent(IN) :: compido + + character(len=*),parameter :: subname = "(seq_mctext_gsmapCreate) " + integer :: n,m,k + integer :: ktot ! number of active cells in gsmap + integer :: apesi, apeso ! number of active pes in gsmap + integer :: lsizeo ! local size for lindex + integer :: ngsegi,ngsego ! ngseg of mpicomi, mpicomo + integer :: gsizei,gsizeo ! gsize of mpicomi, mpicomo + integer :: msizei,msizeo ! size of mpicomi, mpicomo + integer :: mranki,mranko ! rank in mpicomi, mpicomo + integer :: ierr + integer :: decomp_type + integer, pointer :: start(:),length(:),peloc(:),perm(:),gindex(:),lindex(:) + real(r8):: rpeloc + logical :: gsmap_bfbflag = .false. ! normally this should be set to false + + ! --- create a new gsmap on new pes based on the old gsmap + ! --- gsmapi must be known on all mpicomo pes, compute the same + ! --- thing on all pes in parallel + + if (mpicomo /= MPI_COMM_NULL) then + call mpi_comm_rank(mpicomi,mranki,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank i') + call mpi_comm_size(mpicomi,msizei,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size i') + call mpi_comm_rank(mpicomo,mranko,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank o') + call mpi_comm_size(mpicomo,msizeo,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size o') + + ngsegi = gsmapi%ngseg + gsizei = gsmapi%gsize + gsizeo = gsizei + call mct_gsMap_activepes(gsmapi,apesi) + + decomp_type = 0 + + if (seq_mctext_decomp == 0) then + if (msizeo == apesi) then ! preserve segments and decomp + ! For testing - set decomp_type to 1 - to have gsmapi and gsmapo identical + if (gsmap_bfbflag) then + decomp_type = 1 ! better in cpl to have all decomps "same-ish" + else + decomp_type = 2 + end if + elseif (ngsegi >= msizeo) then ! preserve segments, new decomp + decomp_type = 2 + else ! new segments + decomp_type = 3 + endif + else + decomp_type = seq_mctext_decomp + endif + + !tcx decomp_type = 3 ! over ride setting above for testing + ! if (mranko == 0) write(logunit,'(2A,4I)') trim(subname),' decomp_type =',decomp_type,ngsegi,msizeo,apesi + + select case (decomp_type) + + case(1) ! --- preserve segments and decomp --------------------- + + ! -- copy the gsmap and translate the pes + call mct_gsMap_copy(gsmapi,gsmapo) + ngsego = ngsegi + do n = 1,ngsego + gsmapo%pe_loc(n) = mod(gsmapo%pe_loc(n),msizeo) ! translate pes 1:1 from old to new + enddo + + case(2) ! --- preserve segments, new decomp -------------------- + + ! --- preserve segments, sort the start and length, assign a new pe list + ngsego = ngsegi + allocate(start(ngsego),length(ngsego),peloc(ngsego),perm(ngsego)) + do n = 1,ngsego + start(n) = gsmapi%start(n) + length(n) = gsmapi%length(n) + enddo + ! --- sort gsmap to minimize permute cost in mct + call mct_indexset(perm) + call mct_indexsort(ngsego,perm,start) + call mct_permute(start,perm,ngsego) + call mct_permute(length,perm,ngsego) + ! --- give each pe "equal" number of segments, use reals to avoid integer overflow + do n = 1,ngsego + rpeloc = (((msizeo*c1)*((n-1)*c1))/(ngsego*c1)) ! give each pe "equal" number of segments, use reals to avoid integer overflow + peloc(n) = int(rpeloc) + enddo + call mct_gsmap_init(gsmapo,ngsego,start,length,peloc,0,mpicomo,compido,gsizeo) + deallocate(start,length,peloc,perm) + + case(3) ! --- new segments, new decomp ------------------------- + + ! --- new segments, compute gindex, then parse the gridcells out evenly + + k = 0 + do n = 1,ngsegi + do m = 1,gsmapi%length(n) + k = k + 1 + if (k > gsizei) then + write(logunit,*) trim(subname),' ERROR in gindex ',k,gsizei + call shr_sys_abort() + endif + enddo + enddo + ktot = k + + allocate(gindex(ktot),perm(ktot)) + + k = 0 + do n = 1,ngsegi + do m = 1,gsmapi%length(n) + k = k + 1 + gindex(k) = gsmapi%start(n) + m - 1 + enddo + enddo + call mct_indexset(perm) + call mct_indexsort(ktot,perm,gindex) + call mct_permute(gindex,perm,ktot) + + k = 0 + do m = 0,msizeo-1 + lsizeo = ktot/msizeo + if (m < (ktot - lsizeo*msizeo)) lsizeo = lsizeo + 1 + if (mranko == m) then + allocate(lindex(lsizeo)) + if (k+lsizeo > ktot) then + write(logunit,*) trim(subname),' ERROR: decomp out of bounds ',mranko,k,lsizeo,ktot + call shr_sys_abort() + endif + lindex(1:lsizeo) = gindex(k+1:k+lsizeo) + ! write(logunit,*) trim(subname),' decomp is ',mranko,lsizeo,k+1,k+lsizeo + endif + k = k + lsizeo + enddo + if (k /= ktot) then + write(logunit,*) trim(subname),' ERROR: decomp incomplete ',k,ktot + call shr_sys_abort() + endif + + call mct_gsmap_init(gsmapo,lindex,mpicomo,compido,size(lindex),gsizeo) + deallocate(gindex,perm,lindex) + + case default ! --- unknown --- + write(logunit,*) trim(subname),' ERROR decomp_type unknown ',decomp_type + call shr_sys_abort(trim(subname)//' ERROR decomp_type unknown') + + end select + + if (mranko == 0) then + write(logunit,102) trim(subname),' created new gsmap decomp_type =',decomp_type + write(logunit,102) trim(subname),' ngseg/gsize = ', & + mct_gsmap_ngseg(gsmapo),mct_gsmap_gsize(gsmapo) + call mct_gsmap_activepes(gsmapo,apeso) + write(logunit,102) trim(subname),' mpisize/active_pes = ', & + msizeo,apeso + write(logunit,102) trim(subname),' avg seg per pe/ape = ', & + mct_gsmap_ngseg(gsmapo)/msizeo,mct_gsmap_ngseg(gsmapo)/apeso + write(logunit,102) trim(subname),' nlseg/maxnlsegs = ', & + mct_gsmap_nlseg(gsmapo,0),mct_gsmap_maxnlseg(gsmapo) +102 format(2A,2I8) + endif + + ! if (.not. mct_gsmap_increasing(gsmapo) ) then + ! write(logunit,*) trim(subname),' ERROR: gsmapo not increasing' + ! call shr_sys_abort() + ! endif + + endif + + end subroutine seq_mctext_gsmapCreate + + !======================================================================= + + subroutine seq_mctext_avExtend(AVin,IDin,ID) + + !----------------------------------------------------------------------- + ! Extend an AV to a larger set of pes or + ! Initialize an AV on another set of pes + ! + ! Arguments + ! + type(mct_aVect), intent(INOUT):: AVin + integer ,intent(IN) :: IDin ! ID associated with AVin + integer , intent(IN) :: ID ! ID to initialize over + ! + ! Local variables + ! + character(len=*),parameter :: subname = "(seq_mctext_avExtend) " + integer :: mpicom + integer :: rank,rank2 + integer :: lsizei, lsizen + integer :: srank,srankg + integer :: ierr + integer :: nints + character(len=CXX) :: iList,rList + !----------------------------------------------------------------------- + + call seq_comm_getinfo(ID,mpicom=mpicom,iam=rank) + + ! --- lsizen is the size of the newly initialized AV, zero is valid + ! --- lsizei is -1 on any peszero on any pes where AV is not yet initialized + + lsizei = -1 + if (seq_comm_iamin(IDin)) lsizei = mct_aVect_lsize(AVin) + lsizen = 0 + + ! --- find a pe that already has AVin allocated, use MPI_MAX to do so + ! --- set the pe and broadcast it to all other pes using mpi_allreduce + + srank = -1 + srankg = -1 + if (lsizei > 0) srank = rank + + call mpi_allreduce(srank,srankg,1,MPI_INTEGER,MPI_MAX,mpicom,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_allreduce max') + + if (srankg < 0) then + write(logunit,*) subname,' WARNING AVin empty ' + return + endif + + ! --- set the iList and rList from the broadcast pe (srankg) and + ! --- broadcast the lists + + iList = " " + rList = " " + if (rank == srankg) then + if (mct_aVect_nIAttr(AVin) /= 0) iList = mct_aVect_ExportIList2c(AVin) + if (mct_aVect_nRattr(AVin) /= 0) rList = mct_aVect_ExportRList2c(AVin) + endif + + call mpi_bcast(iList,len(iList),MPI_CHARACTER,srankg,mpicom,ierr) + call mpi_bcast(rList,len(rList),MPI_CHARACTER,srankg,mpicom,ierr) + + ! --- now allocate the AV on any pes where the orig size is zero. those + ! --- should be pes that either have no data and may have been allocated + ! --- before (no harm in doing it again) or have never been allocated + + if (lsizei <= 0) then + if(len_trim(iList) > 0 .and. len_trim(rList) > 0) then + call mct_aVect_init(AVin,iList=iList,rList=rList,lsize=lsizen) + elseif (len_trim(iList) > 0 .and. len_trim(rList) == 0) then + call mct_aVect_init(AVin,iList=iList,lsize=lsizen) + elseif (len_trim(iList) == 0 .and. len_trim(rList) > 0) then + call mct_aVect_init(AVin,rList=rList,lsize=lsizen) + endif + endif + + end subroutine seq_mctext_avExtend + + !======================================================================= + + subroutine seq_mctext_avCreate(AVin,IDin,AVout,ID,lsize) + + !----------------------------------------------------------------------- + ! Extend an AV to a larger set of pes or + ! Initialize an AV on another set of pes + !----------------------------------------------------------------------- + + implicit none + type(mct_aVect), intent(INOUT):: AVin + integer ,intent(IN) :: IDin ! ID associated with AVin + type(mct_aVect), intent(INOUT):: AVout + integer , intent(IN) :: ID ! ID to initialize over + integer , intent(IN) :: lsize + + ! Local variables + + character(len=*),parameter :: subname = "(seq_mctext_avCreate) " + integer :: mpicom + integer :: rank,rank2 + integer :: lsizei, lsizen + integer :: srank,srankg + integer :: ierr + integer :: nints + character(len=CXX) :: iList,rList + + call seq_comm_getinfo(ID,mpicom=mpicom,iam=rank) + + ! --- lsizen is the size of the newly initialized AV, zero is valid + + lsizei = -1 + if (seq_comm_iamin(IDin)) lsizei = mct_aVect_lsize(AVin) + lsizen = lsize + + ! --- find a pe that already has AVin allocated, use MPI_MAX to do so + ! --- set the pe and broadcast it to all other pes + + srank = -1 + srankg = -1 + if (lsizei > 0) srank = rank + + call mpi_allreduce(srank,srankg,1,MPI_INTEGER,MPI_MAX,mpicom,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_allreduce max') + + if (srankg < 0) then + write(logunit,*) subname,' ERROR AVin not initialized ' + call shr_sys_abort() + endif + + ! --- set the iList and rList from the broadcast pe (srankg) and + ! --- broadcast the lists + + iList = " " + rList = " " + if (rank == srankg) then + if (mct_aVect_nIAttr(AVin) /= 0) iList = mct_aVect_ExportIList2c(AVin) + if (mct_aVect_nRattr(AVin) /= 0) rList = mct_aVect_ExportRList2c(AVin) + endif + + call mpi_bcast(iList,len(iList),MPI_CHARACTER,srankg,mpicom,ierr) + call mpi_bcast(rList,len(rList),MPI_CHARACTER,srankg,mpicom,ierr) + + ! --- now allocate the AV on all pes. the AV should not exist before. + ! --- If it does, mct should die. + + if(len_trim(iList) > 0 .and. len_trim(rList) > 0) then + call mct_aVect_init(AVout,iList=iList,rList=rList,lsize=lsizen) + elseif (len_trim(iList) > 0 .and. len_trim(rList) == 0) then + call mct_aVect_init(AVout,iList=iList,lsize=lsizen) + elseif (len_trim(iList) == 0 .and. len_trim(rList) > 0) then + call mct_aVect_init(AVout,rList=rList,lsize=lsizen) + endif + + end subroutine seq_mctext_avCreate + + !======================================================================= + + logical function seq_mctext_gsmapIdentical(gsmap1,gsmap2) + + implicit none + type(mct_gsMap), intent(IN):: gsmap1 + type(mct_gsMap), intent(IN):: gsmap2 + + ! Local variables + + character(len=*),parameter :: subname = "(seq_mctext_gsmapIdentical) " + integer :: n + logical :: identical + + !----------------------- + + identical = .true. + + ! --- continue compare --- + if (identical) then + if (mct_gsMap_gsize(gsmap1) /= mct_gsMap_gsize(gsmap2)) identical = .false. + if (mct_gsMap_ngseg(gsmap1) /= mct_gsMap_ngseg(gsmap2)) identical = .false. + endif + + ! --- continue compare --- + if (identical) then + do n = 1,mct_gsMap_ngseg(gsmap1) + if (gsmap1%start(n) /= gsmap2%start(n) ) identical = .false. + if (gsmap1%length(n) /= gsmap2%length(n)) identical = .false. + if (gsmap1%pe_loc(n) /= gsmap2%pe_loc(n)) identical = .false. + enddo + endif + + seq_mctext_gsmapIdentical = identical + + end function seq_mctext_gsmapIdentical + +end module cplcomp_exchange_mod diff --git a/driver-mct/main/map_glc2lnd_mod.F90 b/driver-mct/main/map_glc2lnd_mod.F90 new file mode 100644 index 000000000000..c95649176ba2 --- /dev/null +++ b/driver-mct/main/map_glc2lnd_mod.F90 @@ -0,0 +1,400 @@ +module map_glc2lnd_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains routines for mapping fields from the GLC grid onto the LND grid + ! (separated by GLC elevation class) + ! + ! For high-level design, see: + ! https://docs.google.com/document/d/1sjsaiPYsPJ9A7dVGJIHGg4rVIY2qF5aRXbNzSXVAafU/edit?usp=sharing + +#include "shr_assert.h" + use seq_comm_mct, only : logunit + use shr_kind_mod, only : r8 => shr_kind_r8 + use glc_elevclass_mod, only : glc_get_num_elevation_classes, glc_get_elevation_class, & + glc_mean_elevation_virtual, glc_elevclass_as_string, & + GLC_ELEVCLASS_ERR_NONE, GLC_ELEVCLASS_ERR_TOO_LOW, & + GLC_ELEVCLASS_ERR_TOO_HIGH, glc_errcode_to_string + use mct_mod + use seq_map_type_mod, only : seq_map + use seq_map_mod, only : seq_map_map + use shr_log_mod, only : errMsg => shr_log_errMsg + use shr_sys_mod, only : shr_sys_abort + + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: map_glc2lnd_ec ! map all fields from GLC -> LND grid that need to be separated by elevation class + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: get_glc_elevation_classes ! get elevation class of each glc cell + private :: get_frac_this_ec ! get fraction in a given elevation class + private :: set_topo_in_virtual_columns + private :: make_aVect_frac_times_icemask + + character(len=*), parameter :: frac_times_icemask_field = 'Sg_frac_times_icemask' + +contains + + !----------------------------------------------------------------------- + subroutine map_glc2lnd_ec(g2x_g, & + frac_field, topo_field, icemask_field, extra_fields, & + mapper, g2x_l) + ! + ! !DESCRIPTION: + ! Maps fields from the GLC grid to the LND grid that need to be separated by + ! elevation class. + ! + ! Maps frac_field, topo_field, plus all fields defined in extra_fields. extra_fields + ! should be a colon-delimited list of fields, giving the field name in the g2x_g + ! attribute vector (i.e., without the elevation class suffixes). + ! + ! Assumes that g2x_g contains: + ! - frac_field + ! - topo_field + ! - icemask_field (Note: this is NOT mapped here, but is needed as an input to the mapping) + ! - each field in extra_fields + ! + ! Assumes that g2x_l contains: + ! - 00, 01, 02, ... + ! - 00, 01, 02, ... + ! - And similarly for each field in extra_fields + ! + ! Currently assumes that all fields are mapped using the same mapper, which should be + ! a conservative mapper (i.e., a flux mapper). + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(in) :: g2x_g + character(len=*), intent(in) :: frac_field ! name of field in g2x_g containing glc ice fraction + character(len=*), intent(in) :: topo_field ! name of field in g2x_g containing glc topo + character(len=*), intent(in) :: icemask_field ! name of field in g2x_g containing ice mask + character(len=*), intent(in) :: extra_fields + type(seq_map), intent(inout) :: mapper + type(mct_aVect), intent(inout) :: g2x_l + + ! + ! !LOCAL VARIABLES: + integer :: lsize_g + integer :: lsize_l + + ! The following need to be pointers to satisfy the MCT interface: + real(r8), pointer :: glc_frac(:) ! total ice fraction in each glc cell + real(r8), pointer :: glc_topo(:) ! topographic height of each glc cell + real(r8), pointer :: glc_frac_this_ec(:) ! ice fraction in this elevation class, for eachglc cell + + integer , allocatable :: glc_elevclass(:) ! elevation class of each glc cell (assuming cell is ice-covered) + integer :: n + character(len=:), allocatable :: elevclass_as_string + character(len=:), allocatable :: frac_field_ec ! field name: frac_field with elev class suffix + character(len=len(extra_fields)+100) :: fields_to_map + character(len=2*len(extra_fields)+100) :: fields_to_map_ec ! fields_to_map with elev class suffixes + integer :: num_fields_to_map + + ! attribute vector holding glc fraction in one elev class, on the glc grid + type(mct_aVect) :: glc_frac_this_ec_g + + ! attribute vector holding glc fraction in one elev class, on the land grid + type(mct_aVect) :: glc_frac_this_ec_l + + ! attribute vector holding the product of (glc fraction in one elev class) x + ! (icemask), on the glc grid + type(mct_aVect) :: glc_frac_this_ec_times_icemask_g + + ! attribute vector holding fields to map (other than fraction) in one elevation + ! class, on the land grid + type(mct_aVect) :: glc_fields_this_ec_l + + character(len=*), parameter :: subname = 'map_glc2lnd_ec' + !----------------------------------------------------------------------- + + ! ------------------------------------------------------------------------ + ! Determine attribute vector sizes + ! ------------------------------------------------------------------------ + + lsize_g = mct_aVect_lsize(g2x_g) + lsize_l = mct_aVect_lsize(g2x_l) + + ! ------------------------------------------------------------------------ + ! Extract special fields from g2x_g + ! ------------------------------------------------------------------------ + + allocate(glc_frac(lsize_g)) + allocate(glc_topo(lsize_g)) + call mct_aVect_exportRattr(g2x_g, frac_field, glc_frac) + call mct_aVect_exportRattr(g2x_g, topo_field, glc_topo) + + ! ------------------------------------------------------------------------ + ! Determine elevation class of each glc point + ! ------------------------------------------------------------------------ + + allocate(glc_elevclass(lsize_g)) + allocate(glc_frac_this_ec(lsize_g)) + call get_glc_elevation_classes(glc_topo, glc_elevclass) + + ! ------------------------------------------------------------------------ + ! Map each elevation class + ! ------------------------------------------------------------------------ + + call shr_string_listMerge(extra_fields, topo_field, fields_to_map) + + do n = 0, glc_get_num_elevation_classes() + + ! ------------------------------------------------------------------------ + ! Put fraction in this elevation class into an attribute vector + ! ------------------------------------------------------------------------ + + call get_frac_this_ec(glc_frac, glc_elevclass, n, glc_frac_this_ec) + call mct_aVect_init(glc_frac_this_ec_g, rList = frac_field, lsize = lsize_g) + call mct_aVect_importRattr(glc_frac_this_ec_g, frac_field, glc_frac_this_ec) + + ! ------------------------------------------------------------------------ + ! Map fraction to the land grid + ! ------------------------------------------------------------------------ + + call mct_aVect_init(glc_frac_this_ec_l, rList = frac_field, lsize = lsize_l) + + call seq_map_map(mapper = mapper, av_s = glc_frac_this_ec_g, av_d = glc_frac_this_ec_l, & + norm = .true., avwts_s = g2x_g, avwtsfld_s = icemask_field) + + elevclass_as_string = glc_elevclass_as_string(n) + frac_field_ec = frac_field // elevclass_as_string + call mct_aVect_copy(glc_frac_this_ec_l, g2x_l, & + rList = frac_field, TrList = frac_field_ec) + + ! ------------------------------------------------------------------------ + ! Map other fields to the land grid + ! + ! Note that bare land values are mapped in the same way as ice-covered values + ! ------------------------------------------------------------------------ + + ! Create a mask that is (fraction in this elevation class) x (icemask). So, only + ! grid cells that are both (a) within the icemask and (b) in this elevation class + ! will be included in the following mapping. + call make_aVect_frac_times_icemask(frac_av = glc_frac_this_ec_g, & + mask_av = g2x_g, & + frac_field = frac_field, & + icemask_field = icemask_field, & + frac_times_icemask_av = glc_frac_this_ec_times_icemask_g) + + call mct_aVect_init(glc_fields_this_ec_l, rList = fields_to_map, lsize = lsize_l) + call seq_map_map(mapper = mapper, av_s = g2x_g, av_d = glc_fields_this_ec_l, & + fldlist = fields_to_map, & + norm = .true., & + avwts_s = glc_frac_this_ec_times_icemask_g, & + avwtsfld_s = frac_times_icemask_field) + + call set_topo_in_virtual_columns(n, glc_frac_this_ec_l, & + frac_field, topo_field, & + glc_fields_this_ec_l) + + call shr_string_listAddSuffix(fields_to_map, glc_elevclass_as_string(n), fields_to_map_ec) + call mct_aVect_copy(glc_fields_this_ec_l, g2x_l, & + rList = fields_to_map, TrList = fields_to_map_ec) + + ! ------------------------------------------------------------------------ + ! Clean up + ! ------------------------------------------------------------------------ + + call mct_aVect_clean(glc_frac_this_ec_l) + call mct_aVect_clean(glc_frac_this_ec_g) + call mct_aVect_clean(glc_frac_this_ec_times_icemask_g) + call mct_aVect_clean(glc_fields_this_ec_l) + + end do + + deallocate(glc_frac) + deallocate(glc_topo) + deallocate(glc_frac_this_ec) + + end subroutine map_glc2lnd_ec + + + !----------------------------------------------------------------------- + subroutine get_glc_elevation_classes(glc_topo, glc_elevclass) + ! + ! !DESCRIPTION: + ! Get elevation class of each grid cell on the glc grid. + ! + ! This does not consider glc_frac: it simply gives the elevation class that the grid + ! cell would be in if it were ice-covered. So it never returns an elevation class of + ! 0 (bare land). (This design would allow us, in the future, to have glc grid cells + ! that are part ice-covered, part ice-free.) + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_topo(:) ! topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + ! Do nothing + case (GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH) + write(logunit,*) subname, ': WARNING, for glc_pt, topo = ', glc_pt, glc_topo(glc_pt) + write(logunit,*) glc_errcode_to_string(err_code) + case default + write(logunit,*) subname, ': ERROR getting elevation class for glc_pt = ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end select + end do + + end subroutine get_glc_elevation_classes + + !----------------------------------------------------------------------- + subroutine get_frac_this_ec(glc_frac, glc_elevclass, this_elevclass, glc_frac_this_ec) + ! + ! !DESCRIPTION: + ! Get fractional ice coverage in a given elevation class. + ! + ! The input glc_elevclass gives the elevation class of each glc grid cell, assuming + ! that the grid cell is ice-covered. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_frac(:) ! total ice sheet fraction in each glc grid cell + integer , intent(in) :: glc_elevclass(:) ! elevation class of each glc grid cell + integer , intent(in) :: this_elevclass ! elevation class index of interest + real(r8), intent(out) :: glc_frac_this_ec(:) ! ice fraction in this elevation class + ! + ! !LOCAL VARIABLES: + integer :: npts + + character(len=*), parameter :: subname = 'get_frac_this_ec' + !----------------------------------------------------------------------- + + npts = size(glc_frac_this_ec) + SHR_ASSERT_FL((size(glc_frac) == npts), __FILE__, __LINE__) + SHR_ASSERT_FL((size(glc_elevclass) == npts), __FILE__, __LINE__) + + if (this_elevclass == 0) then + glc_frac_this_ec(:) = 1._r8 - glc_frac(:) + else + where (glc_elevclass == this_elevclass) + glc_frac_this_ec = glc_frac + elsewhere + glc_frac_this_ec = 0._r8 + end where + end if + + end subroutine get_frac_this_ec + + !----------------------------------------------------------------------- + subroutine set_topo_in_virtual_columns(elev_class, glc_frac_this_ec_l, & + frac_field, topo_field, & + glc_topo_this_ec_l) + ! + ! !DESCRIPTION: + ! Sets the topo field for virtual columns, in a given elevation class. + ! + ! This is needed because virtual columns (i.e., elevation classes that have no + ! contributing glc grid cells) won't have any topographic information mapped onto + ! them, so would otherwise end up with an elevation of 0. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: elev_class + type(mct_aVect), intent(in) :: glc_frac_this_ec_l ! attr vect containing frac_field + character(len=*), intent(in) :: frac_field + character(len=*), intent(in) :: topo_field + type(mct_aVect), intent(inout) :: glc_topo_this_ec_l ! attr vect containing topo_field + ! + ! !LOCAL VARIABLES: + integer :: lsize + real(r8) :: topo_virtual + + ! The following need to be pointers to satisfy the MCT interface: + real(r8), pointer :: frac_l(:) ! ice fraction in this elev class, land grid + real(r8), pointer :: topo_l(:) ! topographic height in this elev class, land grid + + character(len=*), parameter :: subname = 'set_virtual_elevation_classes' + !----------------------------------------------------------------------- + + ! Extract fields from attribute vectors + lsize = mct_aVect_lsize(glc_frac_this_ec_l) + SHR_ASSERT_FL(mct_aVect_lsize(glc_topo_this_ec_l) == lsize, __FILE__, __LINE__) + allocate(frac_l(lsize)) + allocate(topo_l(lsize)) + call mct_aVect_exportRattr(glc_frac_this_ec_l, frac_field, frac_l) + call mct_aVect_exportRattr(glc_topo_this_ec_l, topo_field, topo_l) + + ! Set topo field for virtual columns + topo_virtual = glc_mean_elevation_virtual(elev_class) + where (frac_l <= 0) + topo_l = topo_virtual + end where + + ! Put updated field back in attribute vector + call mct_aVect_importRattr(glc_topo_this_ec_l, topo_field, topo_l) + + deallocate(frac_l) + deallocate(topo_l) + + end subroutine set_topo_in_virtual_columns + + !----------------------------------------------------------------------- + subroutine make_aVect_frac_times_icemask(frac_av, mask_av, frac_field, icemask_field, & + frac_times_icemask_av) + ! + ! !DESCRIPTION: + ! Create an attribute vector that is the product of frac_field and icemask_field + ! + ! The resulting frac_times_icemask_av will have a field frac_times_icemask_field which + ! contains this product. This attribute vector is initialized here; it is expected to + ! come in in an uninitialized/cleaned state. (So it needs to be cleaned with a call to + ! mct_aVect_clean later - including before the next call to this routine.) + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(in) :: frac_av ! attr vect containing frac_field + type(mct_aVect), intent(in) :: mask_av ! attr vect containing icemask_field + character(len=*), intent(in) :: frac_field + character(len=*), intent(in) :: icemask_field + type(mct_aVect), intent(out) :: frac_times_icemask_av ! attr vect that will contain frac_times_icemask_field + ! + ! !LOCAL VARIABLES: + integer :: lsize + + character(len=*), parameter :: subname = 'make_aVect_frac_times_icemask' + !----------------------------------------------------------------------- + + lsize = mct_aVect_lsize(frac_av) + SHR_ASSERT_FL(mct_aVect_lsize(mask_av) == lsize, __FILE__, __LINE__) + + call mct_aVect_init(frac_times_icemask_av, rList = frac_times_icemask_field, lsize = lsize) + call mct_aVect_copy(aVin = frac_av, aVout = frac_times_icemask_av, & + rList = frac_field, TrList = frac_times_icemask_field) + call mct_aVect_mult(frac_times_icemask_av, mask_av, icemask_field) + + end subroutine make_aVect_frac_times_icemask + +end module map_glc2lnd_mod diff --git a/driver-mct/main/map_lnd2glc_mod.F90 b/driver-mct/main/map_lnd2glc_mod.F90 new file mode 100644 index 000000000000..1c764691efc5 --- /dev/null +++ b/driver-mct/main/map_lnd2glc_mod.F90 @@ -0,0 +1,481 @@ +module map_lnd2glc_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains routines for mapping fields from the LND grid (separated by GLC + ! elevation class) onto the GLC grid + ! + ! For high-level design, see: + ! https://docs.google.com/document/d/1H_SuK6SfCv1x6dK91q80dFInPbLYcOkUj_iAa6WRnqQ/edit + +#include "shr_assert.h" + use seq_comm_mct, only: CPLID, GLCID, logunit + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_kind_mod, only : cxx => SHR_KIND_CXX + use glc_elevclass_mod, only : glc_get_num_elevation_classes, glc_get_elevation_class, & + glc_elevclass_as_string, glc_all_elevclass_strings, GLC_ELEVCLASS_STRLEN, & + GLC_ELEVCLASS_ERR_NONE, GLC_ELEVCLASS_ERR_TOO_LOW, & + GLC_ELEVCLASS_ERR_TOO_HIGH, glc_errcode_to_string + use mct_mod + use seq_map_type_mod, only : seq_map + use seq_map_mod, only : seq_map_map + use shr_sys_mod, only : shr_sys_abort + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: map_lnd2glc ! map one field from LND -> GLC grid + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: get_glc_elevation_classes ! get the elevation class of each point on the glc grid + private :: map_bare_land ! remap the field of interest for the bare land "elevation class" + private :: map_ice_covered ! remap the field of interest for all elevation classes (excluding bare land) + +contains + + !----------------------------------------------------------------------- + subroutine map_lnd2glc(l2x_l, landfrac_l, g2x_g, fieldname, & + mapper, l2x_g) + ! + ! !DESCRIPTION: + ! Maps one field from the LND grid to the GLC grid. + ! + ! Mapping is done with a multiplication by landfrac on the source grid, with + ! normalization. + ! + ! Sets the given field within l2x_g, leaving the rest of l2x_g untouched. + ! + ! Assumes that l2x_l contains fields like: + ! - fieldname00 + ! - fieldname01 + ! - fieldname02 + ! - etc. + ! + ! and also: + ! - Sl_topo00 + ! - Sl_topo01 + ! - Sl_topo02 + ! - etc. + ! + ! and l2x_g contains a field named 'fieldname' + ! + ! Assumes that landfrac_l contains the field: + ! - lfrac: land fraction on the land grid + ! + ! Assumes that g2x_g contains the following fields: + ! - Sg_ice_covered: whether each glc grid cell is ice-covered (0 or 1) + ! - Sg_topo: ice topographic height on the glc grid + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect) , intent(in) :: l2x_l ! lnd -> cpl fields on the land grid + type(mct_aVect) , intent(in) :: landfrac_l ! lfrac field on the land grid + type(mct_aVect) , intent(in) :: g2x_g ! glc -> cpl fields on the glc grid + character(len=*) , intent(in) :: fieldname ! name of the field to map + type(seq_map) , intent(inout) :: mapper + type(mct_aVect) , intent(inout) :: l2x_g ! lnd -> cpl fields on the glc grid + ! + ! !LOCAL VARIABLES: + + ! fieldname with trailing blanks removed + character(len=:), allocatable :: fieldname_trimmed + + ! number of points on the GLC grid + integer :: lsize_g + + ! data for bare land on the GLC grid + ! needs to be a pointer to satisfy the MCT interface + real(r8), pointer :: data_g_bareland(:) + + ! data for ice-covered regions on the GLC grid + ! needs to be a pointer to satisfy the MCT interface + real(r8), pointer :: data_g_ice_covered(:) + + ! final data on the GLC grid + ! needs to be a pointer to satisfy the MCT interface + real(r8), pointer :: data_g(:) + + ! whether each point on the glc grid is ice-covered (1) or ice-free (0) + ! needs to be a pointer to satisfy the MCT interface + real(r8), pointer :: glc_ice_covered(:) + + ! ice topographic height on the glc grid + ! needs to be a pointer to satisfy the MCT interface + real(r8), pointer :: glc_topo(:) + + ! elevation class on the glc grid + ! 0 implies bare ground (no ice) + integer, allocatable :: glc_elevclass(:) + + character(len=*), parameter :: subname = 'map_lnd2glc' + !----------------------------------------------------------------------- + + ! ------------------------------------------------------------------------ + ! Initialize temporary arrays and other local variables + ! ------------------------------------------------------------------------ + + lsize_g = mct_aVect_lsize(l2x_g) + + allocate(data_g_ice_covered(lsize_g)) + allocate(data_g_bareland(lsize_g)) + allocate(data_g(lsize_g)) + + fieldname_trimmed = trim(fieldname) + + ! ------------------------------------------------------------------------ + ! Extract necessary fields from g2x_g + ! ------------------------------------------------------------------------ + + allocate(glc_ice_covered(lsize_g)) + allocate(glc_topo(lsize_g)) + call mct_aVect_exportRattr(g2x_g, 'Sg_ice_covered', glc_ice_covered) + call mct_aVect_exportRattr(g2x_g, 'Sg_topo', glc_topo) + + ! ------------------------------------------------------------------------ + ! Determine elevation class of each glc point + ! ------------------------------------------------------------------------ + + allocate(glc_elevclass(lsize_g)) + call get_glc_elevation_classes(glc_ice_covered, glc_topo, glc_elevclass) + + ! ------------------------------------------------------------------------ + ! Map elevation class 0 (bare land) and ice elevation classes + ! ------------------------------------------------------------------------ + + call map_bare_land(l2x_l, landfrac_l, fieldname_trimmed, mapper, data_g_bareland) + + ! Start by setting the output data equal to the bare land value everywhere; this will + ! later get overwritten in places where we have ice + ! + ! TODO(wjs, 2015-01-20) This implies that we pass data to CISM even in places that + ! CISM says is ocean (so CISM will ignore the incoming value). This differs from the + ! current glint implementation, which sets acab and artm to 0 over ocean (although + ! notes that this could lead to a loss of conservation). Figure out how to handle + ! this case. + data_g(:) = data_g_bareland(:) + + ! Map the SMB to ice-covered cells + call map_ice_covered(l2x_l, landfrac_l, fieldname_trimmed, & + glc_topo, mapper, data_g_ice_covered) + + where (glc_elevclass /= 0) + data_g = data_g_ice_covered + end where + + ! ------------------------------------------------------------------------ + ! Set field in output attribute vector + ! ------------------------------------------------------------------------ + + call mct_aVect_importRattr(l2x_g, fieldname_trimmed, data_g) + + ! ------------------------------------------------------------------------ + ! Clean up + ! ------------------------------------------------------------------------ + + deallocate(data_g_ice_covered) + deallocate(data_g_bareland) + deallocate(data_g) + deallocate(glc_ice_covered) + deallocate(glc_topo) + deallocate(glc_elevclass) + + end subroutine map_lnd2glc + + !----------------------------------------------------------------------- + subroutine get_glc_elevation_classes(glc_ice_covered, glc_topo, glc_elevclass) + ! + ! !DESCRIPTION: + ! Get the elevation class of each point on the glc grid. + ! + ! For grid cells that are ice-free, the elevation class is set to 0. + ! + ! All arguments (glc_ice_covered, glc_topo and glc_elevclass) must be the same size. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_ice_covered(:) ! ice-covered (1) vs. ice-free (0) + real(r8), intent(in) :: glc_topo(:) ! ice topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + ! Tolerance for checking whether ice_covered is 0 or 1 + real(r8), parameter :: ice_covered_tol = 1.e-13 + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_ice_covered) == npts), __FILE__, __LINE__) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + if (abs(glc_ice_covered(glc_pt) - 1._r8) < ice_covered_tol) then + ! This is an ice-covered point + + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), 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(logunit,*) subname, ': ERROR getting elevation class for ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end if + else if (abs(glc_ice_covered(glc_pt) - 0._r8) < ice_covered_tol) then + ! This is a bare land point (no ice) + glc_elevclass(glc_pt) = 0 + else + ! glc_ice_covered is some value other than 0 or 1 + ! The lnd -> glc downscaling code would need to be reworked if we wanted to + ! handle a continuous fraction between 0 and 1. + write(logunit,*) subname, ': ERROR: glc_ice_covered must be 0 or 1' + write(logunit,*) 'glc_pt, glc_ice_covered = ', glc_pt, glc_ice_covered(glc_pt) + call shr_sys_abort(subname//': ERROR: glc_ice_covered must be 0 or 1') + end if + end do + + end subroutine get_glc_elevation_classes + + !----------------------------------------------------------------------- + subroutine map_bare_land(l2x_l, landfrac_l, fieldname, mapper, data_g_bare_land) + ! + ! !DESCRIPTION: + ! Remaps the field of interest for the bare land "elevation class". + ! + ! Puts the output in data_g_bare_land, which should already be allocated to have size + ! equal to the number of GLC points that this processor is responsible for. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect) , intent(in) :: l2x_l ! lnd -> cpl fields on the land grid + type(mct_aVect) , intent(in) :: landfrac_l ! lfrac field on the land grid + character(len=*) , intent(in) :: fieldname ! name of the field to map (should have NO trailing blanks) + type(seq_map) , intent(inout) :: mapper + real(r8), pointer, intent(inout) :: data_g_bare_land(:) + ! + ! !LOCAL VARIABLES: + character(len=:), allocatable :: elevclass_as_string + character(len=:), allocatable :: fieldname_bare_land + integer :: lsize_g ! number of points for attribute vectors on the glc grid + type(mct_aVect) :: l2x_g_bare_land ! temporary attribute vector holding the remapped field for bare land + + character(len=*), parameter :: subname = 'map_bare_land' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(associated(data_g_bare_land), __FILE__, __LINE__) + + lsize_g = size(data_g_bare_land) + elevclass_as_string = glc_elevclass_as_string(0) + fieldname_bare_land = fieldname // elevclass_as_string + call mct_aVect_init(l2x_g_bare_land, rList = fieldname_bare_land, lsize = lsize_g) + + call seq_map_map(mapper = mapper, av_s = l2x_l, av_d = l2x_g_bare_land, & + fldlist = fieldname_bare_land, & + norm = .true., & + avwts_s = landfrac_l, & + avwtsfld_s = 'lfrac') + call mct_aVect_exportRattr(l2x_g_bare_land, fieldname_bare_land, data_g_bare_land) + + call mct_aVect_clean(l2x_g_bare_land) + + end subroutine map_bare_land + + !----------------------------------------------------------------------- + subroutine map_ice_covered(l2x_l, landfrac_l, fieldname, & + topo_g, mapper, data_g_ice_covered) + + ! + ! !DESCRIPTION: + ! Remaps the field of interest from the land grid (in multiple elevation classes) + ! to the glc grid + ! + ! Puts the output in data_g_ice_covered, which should already be allocated to have size + ! equal to the number of GLC points that this processor is responsible for. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect) , intent(in) :: l2x_l ! lnd -> cpl fields on the land grid + type(mct_aVect) , intent(in) :: landfrac_l ! lfrac field on the land grid + character(len=*) , intent(in) :: fieldname ! name of the field to map (should have NO trailing blanks) + real(r8) , intent(in) :: topo_g(:) ! topographic height for each point on the glc grid + type(seq_map) , intent(inout) :: mapper + real(r8) , intent(out) :: data_g_ice_covered(:) ! field remapped to glc grid + + ! !LOCAL VARIABLES: + + character(len=*), parameter :: toponame = 'Sl_topo' ! base name for topo fields in l2x_l; + ! actual names will have elevation class suffix + + character(len=GLC_ELEVCLASS_STRLEN), allocatable :: all_elevclass_strings(:) + character(len=:), allocatable :: elevclass_as_string + character(len=:), allocatable :: fieldname_ec + character(len=:), allocatable :: toponame_ec + character(len=:), allocatable :: fieldnamelist + character(len=:), allocatable :: toponamelist + character(len=:), allocatable :: totalfieldlist + + integer :: nEC ! number of elevation classes + integer :: lsize_g ! number of cells on glc grid + integer :: n, ec + integer :: strlen + + real(r8) :: elev_l, elev_u ! lower and upper elevations in interpolation range + real(r8) :: d_elev ! elev_u - elev_l + + type(mct_aVect) :: l2x_g_temp ! temporary attribute vector holding the remapped fields for this elevation class + + real(r8), pointer :: tmp_field_g(:) ! must be a pointer to satisfy the MCT interface + real, pointer :: data_g_EC(:,:) ! remapped field in each glc cell, in each EC + real, pointer :: topo_g_EC(:,:) ! remapped topo in each glc cell, in each EC + + ! 1 is probably enough, but use 10 to be safe, in case the length of the delimiter + ! changes + integer, parameter :: extra_len_for_list_merge = 10 + + character(len=*), parameter :: subname = 'map_ice_covered' + !----------------------------------------------------------------------- + + lsize_g = size(data_g_ice_covered) + nEC = glc_get_num_elevation_classes() + SHR_ASSERT_FL((size(topo_g) == lsize_g), __FILE__, __LINE__) + + ! ------------------------------------------------------------------------ + ! Create temporary vectors + ! ------------------------------------------------------------------------ + + allocate(tmp_field_g(lsize_g)) + allocate(data_g_EC (lsize_g,nEC)) + allocate(topo_g_EC (lsize_g,nEC)) + + ! ------------------------------------------------------------------------ + ! Make a string that concatenates all EC levels of field, as well as the topo + ! The resulting list will look something like this: + ! 'Flgl_qice01:Flgl_qice02: ... :Flgl_qice10:Sl_topo01:Sl_topo02: ... :Sltopo10' + ! ------------------------------------------------------------------------ + + allocate(all_elevclass_strings(1:glc_get_num_elevation_classes())) + all_elevclass_strings = glc_all_elevclass_strings(include_zero = .false.) + fieldnamelist = shr_string_listFromSuffixes( & + suffixes = all_elevclass_strings, & + strBase = fieldname) + toponamelist = shr_string_listFromSuffixes( & + suffixes = all_elevclass_strings, & + strBase = toponame) + strlen = len_trim(fieldnamelist) + len_trim(toponamelist) + extra_len_for_list_merge + allocate(character(len=strlen) :: totalfieldlist) + call shr_string_listMerge(fieldnamelist, toponamelist, totalfieldlist ) + + ! ------------------------------------------------------------------------ + ! Make a temporary attribute vector. + ! For each grid cell on the land grid, this attribute vector contains the field and + ! topo values for all ECs. + ! ------------------------------------------------------------------------ + call mct_aVect_init(l2x_g_temp, rList = totalfieldlist, lsize = lsize_g) + + ! ------------------------------------------------------------------------ + ! Remap all these fields from the land (source) grid to the glc (destination) grid. + ! ------------------------------------------------------------------------ + + call seq_map_map(mapper = mapper, & + av_s = l2x_l, & + av_d = l2x_g_temp, & + fldlist = totalfieldlist, & + norm = .true., & + avwts_s = landfrac_l, & + avwtsfld_s = 'lfrac') + + ! ------------------------------------------------------------------------ + ! Export all elevation classes out of attribute vector and into local 2D arrays (xy,z) + ! ------------------------------------------------------------------------ + + do ec = 1, nEC + elevclass_as_string = glc_elevclass_as_string(ec) + fieldname_ec = fieldname // elevclass_as_string + toponame_ec = toponame // elevclass_as_string + call mct_aVect_exportRattr(l2x_g_temp, fieldname_ec, tmp_field_g) + data_g_EC(:,ec) = tmp_field_g + call mct_aVect_exportRattr(l2x_g_temp, toponame_ec, tmp_field_g) + topo_g_EC(:,ec) = tmp_field_g + enddo + + ! ------------------------------------------------------------------------ + ! Perform vertical interpolation of data onto ice sheet topography + ! ------------------------------------------------------------------------ + + data_g_ice_covered(:) = 0._r8 + + do n = 1, lsize_g + + ! For each ice sheet point, find bounding EC values... + if (topo_g(n) < topo_g_EC(n,1)) then + ! lower than lowest mean EC elevation value + data_g_ice_covered(n) = data_g_EC(n,1) + + else if (topo_g(n) >= topo_g_EC(n,nEC)) then + ! higher than highest mean EC elevation value + data_g_ice_covered(n) = data_g_EC(n,nEC) + + else + ! do linear interpolation of data in the vertical + do ec = 2, nEC + if (topo_g(n) < topo_g_EC(n, ec)) then + elev_l = topo_g_EC(n, ec-1) + elev_u = topo_g_EC(n, ec) + d_elev = elev_u - elev_l + if (d_elev <= 0) then + ! This shouldn't happen, but handle it in case it does. In this case, + ! let's arbitrarily use the mean of the two elevation classes, rather + ! than the weighted mean. + write(logunit,*) subname//' WARNING: topo diff between elevation classes <= 0' + write(logunit,*) 'n, ec, elev_l, elev_u = ', n, ec, elev_l, elev_u + write(logunit,*) 'Simply using mean of the two elevation classes,' + write(logunit,*) 'rather than the weighted mean.' + data_g_ice_covered(n) = data_g_EC(n,ec-1) * 0.5_r8 & + + data_g_EC(n,ec) * 0.5_r8 + else + data_g_ice_covered(n) = data_g_EC(n,ec-1) * (elev_u - topo_g(n)) / d_elev & + + data_g_EC(n,ec) * (topo_g(n) - elev_l) / d_elev + end if + + exit + end if + end do + end if ! topo_g(n) + end do ! lsize_g + + ! ------------------------------------------------------------------------ + ! Clean up + ! ------------------------------------------------------------------------ + + deallocate(tmp_field_g) + deallocate(data_g_EC) + deallocate(topo_g_EC) + + call mct_aVect_clean(l2x_g_temp) + + end subroutine map_ice_covered + +end module map_lnd2glc_mod diff --git a/driver-mct/main/map_lnd2rof_irrig_mod.F90 b/driver-mct/main/map_lnd2rof_irrig_mod.F90 new file mode 100644 index 000000000000..b7be99281faa --- /dev/null +++ b/driver-mct/main/map_lnd2rof_irrig_mod.F90 @@ -0,0 +1,287 @@ +module map_lnd2rof_irrig_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains routines for mapping the irrigation field from the LND grid onto + ! the ROF grid. + ! + ! These routines could go in prep_rof_mod, but are separated into their own module for + ! the sake of (1) testability: this module has fewer dependencies than prep_rof_mod; + ! and (2) symmetry with the lnd2glc and glc2lnd custom mapping routines, which also + ! have their own modules. + +#include "shr_assert.h" + use shr_kind_mod, only : r8 => shr_kind_r8 + use mct_mod + use seq_map_type_mod, only : seq_map + use seq_map_mod, only : seq_map_map + use shr_log_mod, only : errMsg => shr_log_errMsg + + implicit none + private + + ! ------------------------------------------------------------------------ + ! Public interfaces + ! ------------------------------------------------------------------------ + + public :: map_lnd2rof_irrig ! map irrigation from lnd -> rof grid + + ! ------------------------------------------------------------------------ + ! Private interfaces + ! ------------------------------------------------------------------------ + + private :: map_rof2lnd_volr ! map volr from rof -> lnd grid + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + subroutine map_lnd2rof_irrig(l2r_l, r2x_r, irrig_flux_field, & + avwts_s, avwtsfld_s, mapper_Fl2r, mapper_Fr2l, l2r_r) + !--------------------------------------------------------------- + ! Description + ! Do custom mapping for the irrigation flux, from land -> rof. + ! + ! The basic idea is that we want to pull irrigation out of ROF cells proportionally to + ! the river volume (volr) in each cell. This is important in cases where the various + ! ROF cells overlapping a CLM cell have very different volr: If we didn't do this + ! volr-normalized remapping, we'd try to extract the same amount of water from each + ! of the ROF cells, which would be more likely to have withdrawals exceeding + ! available volr. + ! + ! (Both RTM and MOSART have code to handle excess withdrawals, by pulling the excess + ! directly out of the ocean, but we'd like to avoid resorting to this as much as + ! possible.) + ! + ! This mapping works by: + ! + ! (1) Normalizing the land's irrigation flux by volr + ! + ! (2) Mapping this volr-normalized flux to the rof grid + ! + ! (3) Converting the mapped, volr-normalized flux back to a normal + ! (non-volr-normalized) flux on the rof grid. + ! + ! This assumes that the following fields are contained in the attribute vector + ! arguments: + ! + ! - l2r_l: field given by irrig_flux_field (read) + ! - l2r_r: field given by irrig_flux_field (set) + ! - r2x_r: 'Flrr_volrmch' (read) + ! + ! Arguments + type(mct_aVect) , intent(in) :: l2r_l ! lnd -> rof fields on the land grid + type(mct_aVect) , intent(in) :: r2x_r ! rof -> cpl fields on the rof grid + character(len=*) , intent(in) :: irrig_flux_field ! name of irrigation field to remap + type(mct_aVect) , intent(in) :: avwts_s ! attr vect for source weighting + character(len=*) , intent(in) :: avwtsfld_s ! field in avwts_s to use + type(seq_map) , intent(inout) :: mapper_Fl2r ! flux mapper for mapping lnd -> rof + type(seq_map) , intent(inout) :: mapper_Fr2l ! flux mapper for mapping rof -> lnd + type(mct_aVect) , intent(inout) :: l2r_r ! lnd -> rof fields on the rof grid + ! + ! Local variables + integer :: r, l + integer :: lsize_l ! number of land points + integer :: lsize_r ! number of rof points + type(mct_avect) :: irrig_l_av ! temporary attribute vector holding irrigation fluxes on the land grid + type(mct_avect) :: irrig_r_av ! temporary attribute vector holding irrigation fluxes on the rof grid + + ! The following need to be pointers to satisfy the MCT interface: + real(r8), pointer :: volr_r(:) ! river volume on the rof grid + real(r8), pointer :: volr_l(:) ! river volume on the land grid + real(r8), pointer :: irrig_flux_l(:) ! irrigation flux on the land grid [kg m-2 s-1] + real(r8), pointer :: irrig_flux_r(:) ! irrigation flux on the rof grid [kg m-2 s-1] + real(r8), pointer :: irrig_normalized_l(:) ! irrigation normalized by volr, land grid + real(r8), pointer :: irrig_normalized_r(:) ! irrigation normalized by volr, rof grid + real(r8), pointer :: irrig_volr0_l(:) ! irrigation where volr <= 0, land grid + real(r8), pointer :: irrig_volr0_r(:) ! irrigation where volr <= 0, rof grid + + character(len=*), parameter :: volr_field = 'Flrr_volrmch' + character(len=*), parameter :: irrig_normalized_field = 'Flrl_irrig_normalized' + character(len=*), parameter :: irrig_volr0_field = 'Flrl_irrig_volr0' + character(len=*), parameter :: fields_to_remap = & + irrig_normalized_field // ':' // irrig_volr0_field + !--------------------------------------------------------------- + + ! ------------------------------------------------------------------------ + ! Determine attribute vector sizes + ! ------------------------------------------------------------------------ + + lsize_l = mct_aVect_lsize(l2r_l) + lsize_r = mct_aVect_lsize(l2r_r) + + ! ------------------------------------------------------------------------ + ! Extract the necessary fields from attribute vectors + ! ------------------------------------------------------------------------ + + allocate(irrig_flux_l(lsize_l)) + call mct_aVect_exportRattr(l2r_l, irrig_flux_field, irrig_flux_l) + + allocate(volr_r(lsize_r)) + call mct_aVect_exportRattr(r2x_r, volr_field, volr_r) + + ! ------------------------------------------------------------------------ + ! Adjust volr_r, and map it to the land grid + ! ------------------------------------------------------------------------ + + ! Treat any rof point with volr < 0 as if it had volr = 0. Negative volr values can + ! arise in RTM. This fix is needed to avoid mapping negative irrigation to those + ! cells: while conservative, this would be unphysical (it would mean that irrigation + ! actually adds water to those cells). + do r = 1, lsize_r + if (volr_r(r) < 0._r8) then + volr_r(r) = 0._r8 + end if + end do + + allocate(volr_l(lsize_l)) + call map_rof2lnd_volr(volr_r, mapper_Fr2l, volr_l) + + ! ------------------------------------------------------------------------ + ! Determine irrigation normalized by volr + ! + ! In order to avoid possible divide by 0, as well as to handle non-sensical negative + ! volr on the land grid, we divide the land's irrigation flux into two separate flux + ! components: a component where we have positive volr on the land grid (put in + ! irrig_normalized_l, which is mapped using volr-normalization) and a component where + ! we have zero or negative volr on the land grid (put in irrig_volr0_l, which is + ! mapped as a standard flux). We then remap both of these components to the rof grid, + ! and then finally add the two components to determine the total irrigation flux on + ! the rof grid. + ! ------------------------------------------------------------------------ + + allocate(irrig_normalized_l(lsize_l)) + allocate(irrig_volr0_l(lsize_l)) + do l = 1, lsize_l + if (volr_l(l) > 0._r8) then + irrig_normalized_l(l) = irrig_flux_l(l) / volr_l(l) + irrig_volr0_l(l) = 0._r8 + else + irrig_normalized_l(l) = 0._r8 + irrig_volr0_l(l) = irrig_flux_l(l) + end if + end do + + ! ------------------------------------------------------------------------ + ! Map irrigation + ! ------------------------------------------------------------------------ + + call mct_aVect_init(irrig_l_av, rList = fields_to_remap, lsize = lsize_l) + call mct_aVect_importRattr(irrig_l_av, irrig_normalized_field, irrig_normalized_l) + call mct_aVect_importRattr(irrig_l_av, irrig_volr0_field, irrig_volr0_l) + call mct_aVect_init(irrig_r_av, rList = fields_to_remap, lsize = lsize_r) + + ! This mapping uses the same options (such as avwts) as is used for mapping all other + ! fields in prep_rof_calc_l2r_rx + call seq_map_map(mapper = mapper_Fl2r, & + av_s = irrig_l_av, & + av_d = irrig_r_av, & + fldlist = fields_to_remap, & + norm = .true., & + avwts_s = avwts_s, & + avwtsfld_s = avwtsfld_s) + + allocate(irrig_normalized_r(lsize_r)) + allocate(irrig_volr0_r(lsize_r)) + call mct_aVect_exportRattr(irrig_r_av, irrig_normalized_field, irrig_normalized_r) + call mct_aVect_exportRattr(irrig_r_av, irrig_volr0_field, irrig_volr0_r) + + ! ------------------------------------------------------------------------ + ! Convert to a total irrigation flux on the ROF grid, and put this in the l2r_rx + ! attribute vector + ! ------------------------------------------------------------------------ + + allocate(irrig_flux_r(lsize_r)) + do r = 1, lsize_r + irrig_flux_r(r) = (irrig_normalized_r(r) * volr_r(r)) + irrig_volr0_r(r) + end do + + call mct_aVect_importRattr(l2r_r, irrig_flux_field, irrig_flux_r) + + ! ------------------------------------------------------------------------ + ! Clean up + ! ------------------------------------------------------------------------ + + deallocate(volr_r) + deallocate(volr_l) + deallocate(irrig_flux_l) + deallocate(irrig_flux_r) + deallocate(irrig_normalized_l) + deallocate(irrig_normalized_r) + deallocate(irrig_volr0_l) + deallocate(irrig_volr0_r) + call mct_aVect_clean(irrig_l_av) + call mct_aVect_clean(irrig_r_av) + + end subroutine map_lnd2rof_irrig + + subroutine map_rof2lnd_volr(volr_r, mapper_Fr2l, volr_l) + !--------------------------------------------------------------- + ! Description + ! Map volr from the rof grid to the lnd grid. + ! + ! This is needed for the volr-normalization that is done in map_lnd2rof_irrig. + ! + ! Note that this mapping is also done in the course of mapping all rof -> lnd fields + ! in prep_lnd_calc_r2x_lx. However, we do this mapping ourselves here for two reasons: + ! + ! (1) For the sake of this normalization, we change all volr < 0 values to 0; this is + ! not done for the standard rof -> lnd mapping. + ! + ! (2) It's possible that the driver sequencing would be changed such that this rof -> + ! lnd mapping happens before the lnd -> rof mapping. If that happened, then volr_l + ! (i.e., volr that has been mapped to the land grid by prep_lnd_calc_r2x_lx) would + ! be inconsistent with volr_r, which would be a Bad Thing for the + ! volr-normalizated mapping (this mapping would no longer be conservative). So we + ! do the rof -> lnd remapping here to ensure we have a volr_l that is consistent + ! with volr_r. + ! + ! The pointer arguments to this routine should already be allocated to be the + ! appropriate size. + ! + ! Arguments + real(r8), pointer, intent(in) :: volr_r(:) ! river volume on the rof grid (input) + type(seq_map) , intent(inout) :: mapper_Fr2l ! flux mapper for mapping rof -> lnd + real(r8), pointer, intent(inout) :: volr_l(:) ! river volume on the lnd grid (output) (technically intent(in) since intent gives the association status of a pointer, but given as intent(inout) to avoid confusion, since its data are modified) + ! + ! Local variables + integer :: lsize_r ! number of rof points + integer :: lsize_l ! number of lnd points + type(mct_avect) :: volr_r_av ! temporary attribute vector holding volr on the rof grid + type(mct_avect) :: volr_l_av ! temporary attribute vector holding volr on the land grid + + ! This volr field name does not need to agree with the volr field name used in the + ! 'real' attribute vectors + character(len=*), parameter :: volr_field = 'volr' + !--------------------------------------------------------------- + + SHR_ASSERT_FL(associated(volr_r), sourcefile, __LINE__) + SHR_ASSERT_FL(associated(volr_l), sourcefile, __LINE__) + + lsize_r = size(volr_r) + lsize_l = size(volr_l) + + call mct_aVect_init(volr_r_av, rList = volr_field, lsize = lsize_r) + call mct_aVect_importRattr(volr_r_av, volr_field, volr_r) + call mct_aVect_init(volr_l_av, rList = volr_field, lsize = lsize_l) + + ! This mapping uses the same options as the standard rof -> lnd mapping done in + ! prep_lnd_calc_r2x_lx. If that mapping ever changed (e.g., introducing an avwts_s + ! argument), then it's *possible* that we'd want this mapping to change, too. + call seq_map_map(mapper = mapper_Fr2l, & + av_s = volr_r_av, & + av_d = volr_l_av, & + fldlist = volr_field, & + norm = .true.) + + call mct_aVect_exportRattr(volr_l_av, volr_field, volr_l) + + call mct_aVect_clean(volr_r_av) + call mct_aVect_clean(volr_l_av) + + end subroutine map_rof2lnd_volr + +end module map_lnd2rof_irrig_mod diff --git a/driver-mct/main/mrg_mod.F90 b/driver-mct/main/mrg_mod.F90 new file mode 100644 index 000000000000..aa4f2c52042a --- /dev/null +++ b/driver-mct/main/mrg_mod.F90 @@ -0,0 +1,945 @@ +module mrg_mod + + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl + use mct_mod + use seq_cdata_mod + use seq_comm_mct + use seq_infodata_mod + implicit none + save + private ! except + +!-------------------------------------------------------------------------- +! TODO - write summary of naming convention here as well +!-------------------------------------------------------------------------- + + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: mrg_x2a_run_mct + public :: mrg_x2i_run_mct + public :: mrg_x2l_run_mct + public :: mrg_x2r_run_mct + public :: mrg_x2o_run_mct + public :: mrg_x2g_run_mct + public :: mrg_x2s_run_mct + public :: mrg_x2w_run_mct + +!-------------------------------------------------------------------------- +! Private interfaces +!-------------------------------------------------------------------------- + + private :: getfld + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + +!=========================================================================================== +contains +!=========================================================================================== + + subroutine mrg_x2a_run_mct( cdata_a, l2x_a, o2x_a, xao_a, i2x_a, fractions_a, x2a_a ) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_a + type(mct_aVect), intent(in) :: l2x_a + type(mct_aVect), intent(in) :: o2x_a + type(mct_aVect), intent(in) :: xao_a + type(mct_aVect), intent(in) :: i2x_a + type(mct_aVect), intent(in) :: fractions_a + type(mct_aVect), intent(inout) :: x2a_a + !----------------------------------------------------------------------- + ! + ! Local workspace + ! + real(r8) :: fracl, fraci, fraco + integer :: n,ka,ki,kl,ko,kx,kof,kif,klf + integer :: lsize + integer :: index_x2a_Sf_lfrac + integer :: index_x2a_Sf_ifrac + integer :: index_x2a_Sf_ofrac + character(CL) :: field_atm ! string converted to char + character(CL) :: field_lnd ! string converted to char + character(CL) :: field_ice ! string converted to char + character(CL) :: field_xao ! string converted to char + character(CL) :: field_ocn ! string converted to char + character(CL) :: itemc_atm ! string converted to char + character(CL) :: itemc_lnd ! string converted to char + character(CL) :: itemc_ice ! string converted to char + character(CL) :: itemc_xao ! string converted to char + character(CL) :: itemc_ocn ! string converted to char + logical :: iamroot + logical :: first_time = .true. + logical, pointer, save :: lmerge(:),imerge(:),xmerge(:),omerge(:) + integer, pointer, save :: lindx(:), iindx(:), oindx(:),xindx(:) + integer, save :: naflds, klflds,niflds,noflds,nxflds + !----------------------------------------------------------------------- + ! + call seq_comm_setptrs(CPLID, iamroot=iamroot) + + if (first_time) then + + naflds = mct_aVect_nRattr(x2a_a) + klflds = mct_aVect_nRattr(l2x_a) + niflds = mct_aVect_nRattr(i2x_a) + noflds = mct_aVect_nRattr(o2x_a) + nxflds = mct_aVect_nRattr(xao_a) + + allocate(lindx(naflds), lmerge(naflds)) + allocate(iindx(naflds), imerge(naflds)) + allocate(xindx(naflds), xmerge(naflds)) + allocate(oindx(naflds), omerge(naflds)) + + lindx(:) = 0 + iindx(:) = 0 + xindx(:) = 0 + oindx(:) = 0 + lmerge(:) = .true. + imerge(:) = .true. + xmerge(:) = .true. + omerge(:) = .true. + + ! Field naming rules + ! Only atm states that are Sx_... will be merged + ! Only fluxes that are F??x_... will be merged + ! All fluxes will be multiplied by corresponding component fraction + + do ka = 1,naflds + call getfld(ka, x2a_a, field_atm, itemc_atm) + if (field_atm(1:2) == 'PF') then + cycle ! if flux has first character as P, pass straight through + end if + if (field_atm(1:1) == 'S' .and. field_atm(2:2) /= 'x') then + cycle ! any state fields that are not Sx_ will just be copied + end if + + do kl = 1,klflds + call getfld(kl, l2x_a, field_lnd, itemc_lnd) + if (trim(itemc_atm) == trim(itemc_lnd)) then + if ((trim(field_atm) == trim(field_lnd))) then + if (field_lnd(1:1) == 'F') lmerge(ka) = .false. + end if + lindx(ka) = kl + exit + end if + end do + do ki = 1,niflds + call getfld(ki, i2x_a, field_ice, itemc_ice) + if (field_ice(1:1) == 'F' .and. field_ice(2:4) == 'ioi') then + cycle ! ignore all fluxes that are ice/ocn fluxes + end if + if (trim(itemc_atm) == trim(itemc_ice)) then + if ((trim(field_atm) == trim(field_ice))) then + if (field_ice(1:1) == 'F') imerge(ka) = .false. + end if + iindx(ka) = ki + exit + end if + end do + do kx = 1,nxflds + call getfld(kx, xao_a, field_xao, itemc_xao) + if (trim(itemc_atm) == trim(itemc_xao)) then + if ((trim(field_atm) == trim(field_xao))) then + if (field_xao(1:1) == 'F') xmerge(ka) = .false. + end if + xindx(ka) = kx + exit + end if + end do + do ko = 1,noflds + call getfld(ko, o2x_a, field_ocn, itemc_ocn) + if (trim(itemc_atm) == trim(itemc_ocn)) then + if ((trim(field_atm) == trim(field_ocn))) then + if (field_ocn(1:1) == 'F') omerge(ka) = .false. + end if + oindx(ka) = ko + exit + end if + end do + if (lindx(ka) == 0) itemc_lnd = 'unset' + if (iindx(ka) == 0) itemc_ice = 'unset' + if (xindx(ka) == 0) itemc_xao = 'unset' + if (oindx(ka) == 0) itemc_ocn = 'unset' + + if (iamroot) then + write(logunit,10)trim(itemc_atm),trim(itemc_lnd),& + trim(itemc_ice),trim(itemc_xao),trim(itemc_ocn) +10 format(' ',' atm field: ',a15,', lnd merge: ',a15, & + ', ice merge: ',a15,', xao merge: ',a15,', ocn merge: ',a15) + write(logunit, *)'field_atm,lmerge, imerge, xmerge, omerge= ',& + trim(field_atm),lmerge(ka),imerge(ka),xmerge(ka),omerge(ka) + end if + end do + first_time = .false. + end if + + ! Zero attribute vector + + call mct_avect_zero(x2a_a) + + ! Update surface fractions + + kif=mct_aVect_indexRA(fractions_a,"ifrac") + klf=mct_aVect_indexRA(fractions_a,"lfrac") + kof=mct_aVect_indexRA(fractions_a,"ofrac") + lsize = mct_avect_lsize(x2a_a) + + index_x2a_Sf_lfrac = mct_aVect_indexRA(x2a_a,'Sf_lfrac') + index_x2a_Sf_ifrac = mct_aVect_indexRA(x2a_a,'Sf_ifrac') + index_x2a_Sf_ofrac = mct_aVect_indexRA(x2a_a,'Sf_ofrac') + do n = 1,lsize + x2a_a%rAttr(index_x2a_Sf_lfrac,n) = fractions_a%Rattr(klf,n) + x2a_a%rAttr(index_x2a_Sf_ifrac,n) = fractions_a%Rattr(kif,n) + x2a_a%rAttr(index_x2a_Sf_ofrac,n) = fractions_a%Rattr(kof,n) + end do + + ! Copy attributes that do not need to be merged + ! These are assumed to have the same name in + ! (o2x_a and x2a_a) and in (l2x_a and x2a_a), etc. + + call mct_aVect_copy(aVin=l2x_a, aVout=x2a_a, vector=mct_usevector) + call mct_aVect_copy(aVin=o2x_a, aVout=x2a_a, vector=mct_usevector) + call mct_aVect_copy(aVin=i2x_a, aVout=x2a_a, vector=mct_usevector) + call mct_aVect_copy(aVin=xao_a, aVout=x2a_a, vector=mct_usevector) + + ! If flux to atm is coming only from the ocean (based on field being in o2x_a) - + ! -- then scale by both ocean and ice fraction + ! If flux to atm is coming only from the land or ice or coupler + ! -- then do scale by fraction above + + do ka = 1,naflds + do n = 1,lsize + fracl = fractions_a%Rattr(klf,n) + fraci = fractions_a%Rattr(kif,n) + fraco = fractions_a%Rattr(kof,n) + if (lindx(ka) > 0 .and. fracl > 0._r8) then + if (lmerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + l2x_a%rAttr(lindx(ka),n) * fracl + else + x2a_a%rAttr(ka,n) = l2x_a%rAttr(lindx(ka),n) * fracl + end if + end if + if (iindx(ka) > 0 .and. fraci > 0._r8) then + if (imerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + i2x_a%rAttr(iindx(ka),n) * fraci + else + x2a_a%rAttr(ka,n) = i2x_a%rAttr(iindx(ka),n) * fraci + end if + end if + if (xindx(ka) > 0 .and. fraco > 0._r8) then + if (xmerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + xao_a%rAttr(xindx(ka),n) * fraco + else + x2a_a%rAttr(ka,n) = xao_a%rAttr(xindx(ka),n) * fraco + end if + end if + if (oindx(ka) > 0) then + if (omerge(ka) .and. fraco > 0._r8) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + o2x_a%rAttr(oindx(ka),n) * fraco + end if + if (.not. omerge(ka)) then + !--- NOTE: This IS using the ocean fields and ice fraction !! --- + x2a_a%rAttr(ka,n) = o2x_a%rAttr(oindx(ka),n) * fraci + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + o2x_a%rAttr(oindx(ka),n) * fraco + end if + end if + end do + end do + + end subroutine mrg_x2a_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2i_run_mct( cdata_i, a2x_i, o2x_i, x2i_i ) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_cdata),intent(in) :: cdata_i + type(mct_aVect),intent(in) :: a2x_i + type(mct_aVect),intent(in) :: o2x_i + type(mct_aVect),intent(inout):: x2i_i + ! + ! Local variables + ! + integer :: i + real(r8):: flux_epbalfact + character(len=cl) :: flux_epbal + type(seq_infodata_type),pointer :: infodata + integer, save :: index_a2x_Faxa_rainc + integer, save :: index_a2x_Faxa_rainl + integer, save :: index_a2x_Faxa_snowc + integer, save :: index_a2x_Faxa_snowl + integer, save :: index_x2i_Faxa_rain + integer, save :: index_x2i_Faxa_snow + logical, save :: first_time = .true. + logical, save :: flds_wiso = .false. + + !wiso fields: + integer, save :: index_a2x_Faxa_rainc_16O + integer, save :: index_a2x_Faxa_rainl_16O + integer, save :: index_a2x_Faxa_snowc_16O + integer, save :: index_a2x_Faxa_snowl_16O + integer, save :: index_x2i_Faxa_rain_16O + integer, save :: index_x2i_Faxa_snow_16O + integer, save :: index_a2x_Faxa_rainc_18O + integer, save :: index_a2x_Faxa_rainl_18O + integer, save :: index_a2x_Faxa_snowc_18O + integer, save :: index_a2x_Faxa_snowl_18O + integer, save :: index_x2i_Faxa_rain_18O + integer, save :: index_x2i_Faxa_snow_18O + integer, save :: index_a2x_Faxa_rainc_HDO + integer, save :: index_a2x_Faxa_rainl_HDO + integer, save :: index_a2x_Faxa_snowc_HDO + integer, save :: index_a2x_Faxa_snowl_HDO + integer, save :: index_x2i_Faxa_rain_HDO + integer, save :: index_x2i_Faxa_snow_HDO + + !----------------------------------------------------------------------- + + if (first_time) then + index_a2x_Faxa_snowc = mct_aVect_indexRA(a2x_i,'Faxa_snowc') + index_a2x_Faxa_snowl = mct_aVect_indexRA(a2x_i,'Faxa_snowl') + index_a2x_Faxa_rainc = mct_aVect_indexRA(a2x_i,'Faxa_rainc') + index_a2x_Faxa_rainl = mct_aVect_indexRA(a2x_i,'Faxa_rainl') + index_x2i_Faxa_rain = mct_aVect_indexRA(x2i_i,'Faxa_rain' ) + index_x2i_Faxa_snow = mct_aVect_indexRA(x2i_i,'Faxa_snow' ) + + ! H2_16O + index_a2x_Faxa_snowc_16O = mct_aVect_indexRA(a2x_i,'Faxa_snowc_16O', perrWith='quiet') + index_a2x_Faxa_snowl_16O = mct_aVect_indexRA(a2x_i,'Faxa_snowl_16O', perrWith='quiet') + index_a2x_Faxa_rainc_16O = mct_aVect_indexRA(a2x_i,'Faxa_rainc_16O', perrWith='quiet') + index_a2x_Faxa_rainl_16O = mct_aVect_indexRA(a2x_i,'Faxa_rainl_16O', perrWith='quiet') + index_x2i_Faxa_rain_16O = mct_aVect_indexRA(x2i_i,'Faxa_rain_16O' , perrWith='quiet') + index_x2i_Faxa_snow_16O = mct_aVect_indexRA(x2i_i,'Faxa_snow_16O' , perrWith='quiet') + if ( index_x2i_Faxa_rain_16O /= 0 ) flds_wiso = .true. + ! H2_18O + index_a2x_Faxa_snowc_18O = mct_aVect_indexRA(a2x_i,'Faxa_snowc_18O', perrWith='quiet') + index_a2x_Faxa_snowl_18O = mct_aVect_indexRA(a2x_i,'Faxa_snowl_18O', perrWith='quiet') + index_a2x_Faxa_rainc_18O = mct_aVect_indexRA(a2x_i,'Faxa_rainc_18O', perrWith='quiet') + index_a2x_Faxa_rainl_18O = mct_aVect_indexRA(a2x_i,'Faxa_rainl_18O', perrWith='quiet') + index_x2i_Faxa_rain_18O = mct_aVect_indexRA(x2i_i,'Faxa_rain_18O' , perrWith='quiet') + index_x2i_Faxa_snow_18O = mct_aVect_indexRA(x2i_i,'Faxa_snow_18O' , perrWith='quiet') + if ( index_x2i_Faxa_rain_18O /= 0 ) flds_wiso = .true. + ! HDO + index_a2x_Faxa_snowc_HDO = mct_aVect_indexRA(a2x_i,'Faxa_snowc_HDO', perrWith='quiet') + index_a2x_Faxa_snowl_HDO = mct_aVect_indexRA(a2x_i,'Faxa_snowl_HDO', perrWith='quiet') + index_a2x_Faxa_rainc_HDO = mct_aVect_indexRA(a2x_i,'Faxa_rainc_HDO', perrWith='quiet') + index_a2x_Faxa_rainl_HDO = mct_aVect_indexRA(a2x_i,'Faxa_rainl_HDO', perrWith='quiet') + index_x2i_Faxa_rain_HDO = mct_aVect_indexRA(x2i_i,'Faxa_rain_HDO' , perrWith='quiet') + index_x2i_Faxa_snow_HDO = mct_aVect_indexRA(x2i_i,'Faxa_snow_HDO' , perrWith='quiet') + if ( index_x2i_Faxa_rain_HDO /= 0 ) flds_wiso = .true. + + first_time = .false. + end if + + ! Apply correction to precipitation of requested driver namelist + call seq_cdata_setptrs(cdata_i,infodata=infodata) + call seq_infodata_GetData(infodata, flux_epbalfact = flux_epbalfact) + + call mct_aVect_copy(aVin=o2x_i, aVout=x2i_i, vector=mct_usevector) + call mct_aVect_copy(aVin=a2x_i, aVout=x2i_i, vector=mct_usevector) + + ! Merge total snow and precip for ice input + ! Scale total precip and runoff by flux_epbalfact + + do i = 1,mct_aVect_lsize(x2i_i) + x2i_i%rAttr(index_x2i_Faxa_rain,i) = a2x_i%rAttr(index_a2x_Faxa_rainc,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl,i) + x2i_i%rAttr(index_x2i_Faxa_snow,i) = a2x_i%rAttr(index_a2x_Faxa_snowc,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl,i) + + x2i_i%rAttr(index_x2i_Faxa_rain,i) = x2i_i%rAttr(index_x2i_Faxa_rain,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow,i) = x2i_i%rAttr(index_x2i_Faxa_snow,i) * flux_epbalfact + + end do + if ( flds_wiso )then + do i = 1,mct_aVect_lsize(x2i_i) + !H2_16O + x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_16O,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_16O,i) + x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_16O,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_16O,i) + !H2_18O + x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_18O,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_18O,i) + x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_18O,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_18O,i) + !HDO + x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_HDO,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_HDO,i) + x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_HDO,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_HDO,i) + + x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) = x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) = x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) = x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) = x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) = x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) = x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) * flux_epbalfact + + end do + end if + + end subroutine mrg_x2i_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2r_run_mct( cdata_r, l2x_r, fractions_r, x2r_r) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_cdata),intent(in) :: cdata_r + type(mct_aVect),intent(in) :: l2x_r + type(mct_aVect),intent(in) :: fractions_r + type(mct_aVect),intent(inout):: x2r_r + ! + ! Local variables + ! + integer :: i + type(seq_infodata_type),pointer :: infodata + integer, save :: index_l2x_Flrl_rofliq + integer, save :: index_l2x_Flrl_rofice + integer, save :: index_x2r_Flrl_rofliq + integer, save :: index_x2r_Flrl_rofice + integer, save :: index_l2x_Flrl_rofliq_16O + integer, save :: index_l2x_Flrl_rofice_16O + integer, save :: index_x2r_Flrl_rofliq_16O + integer, save :: index_x2r_Flrl_rofice_16O + integer, save :: index_l2x_Flrl_rofliq_18O + integer, save :: index_l2x_Flrl_rofice_18O + integer, save :: index_x2r_Flrl_rofliq_18O + integer, save :: index_x2r_Flrl_rofice_18O + integer, save :: index_l2x_Flrl_rofliq_HDO + integer, save :: index_l2x_Flrl_rofice_HDO + integer, save :: index_x2r_Flrl_rofliq_HDO + integer, save :: index_x2r_Flrl_rofice_HDO + integer, save :: index_lfrac + logical, save :: first_time = .true. + logical, save :: flds_wiso = .false. + real(r8) :: lfrac + !----------------------------------------------------------------------- + + if (first_time) then + index_l2x_Flrl_rofliq = mct_aVect_indexRA(l2x_r,'Flrl_rofliq' ) + index_l2x_Flrl_rofice = mct_aVect_indexRA(l2x_r,'Flrl_rofice' ) + index_x2r_Flrl_rofliq = mct_aVect_indexRA(x2r_r,'Flrl_rofliq' ) + index_x2r_Flrl_rofice = mct_aVect_indexRA(x2r_r,'Flrl_rofice' ) + index_l2x_Flrl_rofliq_16O = mct_aVect_indexRA(l2x_r,'Flrl_rofliq_16O', perrWith='quiet' ) + index_l2x_Flrl_rofice_16O = mct_aVect_indexRA(l2x_r,'Flrl_rofice_16O', perrWith='quiet' ) + index_x2r_Flrl_rofliq_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofliq_16O', perrWith='quiet' ) + index_x2r_Flrl_rofice_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofice_16O', perrWith='quiet' ) + if ( index_l2x_Flrl_rofliq_16O /= 0 ) flds_wiso = .true. + index_l2x_Flrl_rofliq_18O = mct_aVect_indexRA(l2x_r,'Flrl_rofliq_18O', perrWith='quiet' ) + index_l2x_Flrl_rofice_18O = mct_aVect_indexRA(l2x_r,'Flrl_rofice_18O', perrWith='quiet' ) + index_x2r_Flrl_rofliq_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofliq_18O', perrWith='quiet' ) + index_x2r_Flrl_rofice_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofice_18O', perrWith='quiet' ) + if ( index_l2x_Flrl_rofliq_18O /= 0 ) flds_wiso = .true. + index_l2x_Flrl_rofliq_HDO = mct_aVect_indexRA(l2x_r,'Flrl_rofliq_HDO', perrWith='quiet' ) + index_l2x_Flrl_rofice_HDO = mct_aVect_indexRA(l2x_r,'Flrl_rofice_HDO', perrWith='quiet' ) + index_x2r_Flrl_rofliq_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofliq_HDO', perrWith='quiet' ) + index_x2r_Flrl_rofice_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofice_HDO', perrWith='quiet' ) + if ( index_l2x_Flrl_rofliq_HDO /= 0 ) flds_wiso = .true. + index_lfrac = mct_aVect_indexRA(fractions_r,"lfrac") + first_time = .false. + end if + + ! Merge land rof and ice forcing for rof input + + do i = 1,mct_aVect_lsize(x2r_r) + lfrac = fractions_r%rAttr(index_lfrac,i) + x2r_r%rAttr(index_x2r_Flrl_rofliq,i) = l2x_r%rAttr(index_l2x_Flrl_rofliq,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofice,i) = l2x_r%rAttr(index_l2x_Flrl_rofice,i) * lfrac + end do + if ( flds_wiso ) then + do i = 1,mct_aVect_lsize(x2r_r) + lfrac = fractions_r%rAttr(index_lfrac,i) + x2r_r%rAttr(index_x2r_Flrl_rofliq_16O,i) = l2x_r%rAttr(index_l2x_Flrl_rofliq_16O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofice_16O,i) = l2x_r%rAttr(index_l2x_Flrl_rofice_16O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofliq_18O,i) = l2x_r%rAttr(index_l2x_Flrl_rofliq_18O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofice_18O,i) = l2x_r%rAttr(index_l2x_Flrl_rofice_18O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofliq_HDO,i) = l2x_r%rAttr(index_l2x_Flrl_rofliq_HDO,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofice_HDO,i) = l2x_r%rAttr(index_l2x_Flrl_rofice_HDO,i) * lfrac + end do + end if + + end subroutine mrg_x2r_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2l_run_mct( cdata_l, a2x_l, r2l_l, x2l_l ) + + !----------------------------------------------------------------------- + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_l + type(mct_aVect), intent(in) :: a2x_l ! input + type(mct_aVect), intent(in) :: r2l_l ! input + type(mct_aVect), intent(inout) :: x2l_l ! output + !----------------------------------------------------------------------- + + ! Create input land state directly from atm and runoff outputs + call mct_aVect_copy(aVin=a2x_l, aVout=x2l_l, vector=mct_usevector) + call mct_aVect_copy(aVin=r2l_l, aVout=x2l_l, vector=mct_usevector) + + end subroutine mrg_x2l_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2o_run_mct( cdata_o, a2x_o, i2x_o, w2x_o, xao_o, fractions_o, x2o_o ) + + !----------------------------------------------------------------------- + ! Arguments + type(seq_cdata), intent(in) :: cdata_o + type(mct_aVect), intent(in) :: a2x_o + type(mct_aVect), intent(in) :: i2x_o + type(mct_aVect), intent(in) :: w2x_o + type(mct_aVect), intent(in) :: xao_o + type(mct_aVect), intent(in) :: fractions_o + type(mct_aVect), intent(inout) :: x2o_o + ! + ! Local variables + ! + integer :: n,ka,ki,ko,kir,kor + integer :: lsize + real(r8) :: ifrac,ifracr + real(r8) :: afrac,afracr + real(r8) :: flux_epbalfact + real(r8) :: frac_sum + real(r8) :: avsdr, anidr, avsdf, anidf ! albedos + real(r8) :: fswabsv, fswabsi ! sw + integer :: noflds,naflds,niflds,nxflds + integer :: kof,kaf,kif,kxf + character(len=cl) :: flux_epbal + character(CL) :: field_ocn ! string converted to char + character(CL) :: field_atm ! string converted to char + character(CL) :: field_ice ! string converted to char + character(CL) :: field_xao ! string converted to char + character(CL) :: itemc_ocn ! string converted to char + character(CL) :: itemc_atm ! string converted to char + character(CL) :: itemc_ice ! string converted to char + character(CL) :: itemc_xao ! string converted to char + logical :: iamroot + type(seq_infodata_type),pointer :: infodata + integer, save :: index_a2x_Faxa_swvdr + integer, save :: index_a2x_Faxa_swvdf + integer, save :: index_a2x_Faxa_swndr + integer, save :: index_a2x_Faxa_swndf + integer, save :: index_i2x_Fioi_swpen + integer, save :: index_xao_So_avsdr + integer, save :: index_xao_So_anidr + integer, save :: index_xao_So_avsdf + integer, save :: index_xao_So_anidf + integer, save :: index_a2x_Faxa_snowc + integer, save :: index_a2x_Faxa_snowl + integer, save :: index_a2x_Faxa_rainc + integer, save :: index_a2x_Faxa_rainl + integer, save :: index_x2o_Foxx_swnet + integer, save :: index_x2o_Faxa_snow + integer, save :: index_x2o_Faxa_rain + integer, save :: index_x2o_Faxa_prec + + !wiso fields: + integer, save :: index_a2x_Faxa_rainc_16O + integer, save :: index_a2x_Faxa_rainl_16O + integer, save :: index_a2x_Faxa_snowc_16O + integer, save :: index_a2x_Faxa_snowl_16O + integer, save :: index_x2o_Faxa_rain_16O + integer, save :: index_x2o_Faxa_snow_16O + integer, save :: index_x2o_Faxa_prec_16O + integer, save :: index_a2x_Faxa_rainc_18O + integer, save :: index_a2x_Faxa_rainl_18O + integer, save :: index_a2x_Faxa_snowc_18O + integer, save :: index_a2x_Faxa_snowl_18O + integer, save :: index_x2o_Faxa_rain_18O + integer, save :: index_x2o_Faxa_snow_18O + integer, save :: index_x2o_Faxa_prec_18O + integer, save :: index_a2x_Faxa_rainc_HDO + integer, save :: index_a2x_Faxa_rainl_HDO + integer, save :: index_a2x_Faxa_snowc_HDO + integer, save :: index_a2x_Faxa_snowl_HDO + integer, save :: index_x2o_Faxa_rain_HDO + integer, save :: index_x2o_Faxa_snow_HDO + integer, save :: index_x2o_Faxa_prec_HDO + + logical, save, pointer :: amerge(:),imerge(:),xmerge(:) + integer, save, pointer :: aindx(:), iindx(:), oindx(:), xindx(:) + logical, save :: first_time = .true. + logical, save :: flds_wiso = .false. + character(*),parameter :: subName = '(mrg_x2o_run_mct) ' + !----------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID, iamroot=iamroot) + + noflds = mct_aVect_nRattr(x2o_o) + naflds = mct_aVect_nRattr(a2x_o) + niflds = mct_aVect_nRattr(i2x_o) + nxflds = mct_aVect_nRattr(xao_o) + + if (first_time) then + index_a2x_Faxa_swvdr = mct_aVect_indexRA(a2x_o,'Faxa_swvdr') + index_a2x_Faxa_swvdf = mct_aVect_indexRA(a2x_o,'Faxa_swvdf') + index_a2x_Faxa_swndr = mct_aVect_indexRA(a2x_o,'Faxa_swndr') + index_a2x_Faxa_swndf = mct_aVect_indexRA(a2x_o,'Faxa_swndf') + index_i2x_Fioi_swpen = mct_aVect_indexRA(i2x_o,'Fioi_swpen') + index_xao_So_avsdr = mct_aVect_indexRA(xao_o,'So_avsdr') + index_xao_So_anidr = mct_aVect_indexRA(xao_o,'So_anidr') + index_xao_So_avsdf = mct_aVect_indexRA(xao_o,'So_avsdf') + index_xao_So_anidf = mct_aVect_indexRA(xao_o,'So_anidf') + index_x2o_Foxx_swnet = mct_aVect_indexRA(x2o_o,'Foxx_swnet') + + index_a2x_Faxa_snowc = mct_aVect_indexRA(a2x_o,'Faxa_snowc') + index_a2x_Faxa_snowl = mct_aVect_indexRA(a2x_o,'Faxa_snowl') + index_a2x_Faxa_rainc = mct_aVect_indexRA(a2x_o,'Faxa_rainc') + index_a2x_Faxa_rainl = mct_aVect_indexRA(a2x_o,'Faxa_rainl') + index_x2o_Faxa_snow = mct_aVect_indexRA(x2o_o,'Faxa_snow') + index_x2o_Faxa_rain = mct_aVect_indexRA(x2o_o,'Faxa_rain') + index_x2o_Faxa_prec = mct_aVect_indexRA(x2o_o,'Faxa_prec') + + !wiso: + ! H2_16O + index_a2x_Faxa_snowc_16O = mct_aVect_indexRA(a2x_o,'Faxa_snowc_16O', perrWith='quiet') + index_a2x_Faxa_snowl_16O = mct_aVect_indexRA(a2x_o,'Faxa_snowl_16O', perrWith='quiet') + index_a2x_Faxa_rainc_16O = mct_aVect_indexRA(a2x_o,'Faxa_rainc_16O', perrWith='quiet') + index_a2x_Faxa_rainl_16O = mct_aVect_indexRA(a2x_o,'Faxa_rainl_16O', perrWith='quiet') + index_x2o_Faxa_rain_16O = mct_aVect_indexRA(x2o_o,'Faxa_rain_16O' , perrWith='quiet') + index_x2o_Faxa_snow_16O = mct_aVect_indexRA(x2o_o,'Faxa_snow_16O' , perrWith='quiet') + index_x2o_Faxa_prec_16O = mct_aVect_indexRA(x2o_o,'Faxa_prec_16O' , perrWith='quiet') + if ( index_x2o_Faxa_rain_16O /= 0 ) flds_wiso = .true. + ! H2_18O + index_a2x_Faxa_snowc_18O = mct_aVect_indexRA(a2x_o,'Faxa_snowc_18O', perrWith='quiet') + index_a2x_Faxa_snowl_18O = mct_aVect_indexRA(a2x_o,'Faxa_snowl_18O', perrWith='quiet') + index_a2x_Faxa_rainc_18O = mct_aVect_indexRA(a2x_o,'Faxa_rainc_18O', perrWith='quiet') + index_a2x_Faxa_rainl_18O = mct_aVect_indexRA(a2x_o,'Faxa_rainl_18O', perrWith='quiet') + index_x2o_Faxa_rain_18O = mct_aVect_indexRA(x2o_o,'Faxa_rain_18O' , perrWith='quiet') + index_x2o_Faxa_snow_18O = mct_aVect_indexRA(x2o_o,'Faxa_snow_18O' , perrWith='quiet') + index_x2o_Faxa_prec_18O = mct_aVect_indexRA(x2o_o,'Faxa_prec_18O' , perrWith='quiet') + if ( index_x2o_Faxa_rain_18O /= 0 ) flds_wiso = .true. + ! HDO + index_a2x_Faxa_snowc_HDO = mct_aVect_indexRA(a2x_o,'Faxa_snowc_HDO', perrWith='quiet') + index_a2x_Faxa_snowl_HDO = mct_aVect_indexRA(a2x_o,'Faxa_snowl_HDO', perrWith='quiet') + index_a2x_Faxa_rainc_HDO = mct_aVect_indexRA(a2x_o,'Faxa_rainc_HDO', perrWith='quiet') + index_a2x_Faxa_rainl_HDO = mct_aVect_indexRA(a2x_o,'Faxa_rainl_HDO', perrWith='quiet') + index_x2o_Faxa_rain_HDO = mct_aVect_indexRA(x2o_o,'Faxa_rain_HDO' , perrWith='quiet') + index_x2o_Faxa_snow_HDO = mct_aVect_indexRA(x2o_o,'Faxa_snow_HDO' , perrWith='quiet') + index_x2o_Faxa_prec_HDO = mct_aVect_indexRA(x2o_o,'Faxa_prec_HDO' , perrWith='quiet') + if ( index_x2o_Faxa_rain_HDO /= 0 ) flds_wiso = .true. + + + + ! Compute all other quantities based on standardized naming convention (see below) + ! Only ocn field states that have the name-prefix Sx_ will be merged + ! Only field names have the same name-suffix (after the "_") will be merged + ! (e.g. Si_fldname, Sa_fldname => merged to => Sx_fldname) + ! All fluxes will be scaled by the corresponding afrac or ifrac + ! EXCEPT for + ! -- Faxa_snnet, Faxa_snow, Faxa_rain, Faxa_prec (derived) + ! -- Forr_* (treated in ccsm_comp_mod) + ! All i2x_o fluxes that have the name-suffix "Faii" (atm/ice fluxes) will be ignored + ! - only ice fluxes that are Fioi_... will be used in the ocean merges + + allocate(aindx(noflds), amerge(noflds)) + allocate(iindx(noflds), imerge(noflds)) + allocate(xindx(noflds), xmerge(noflds)) + aindx(:) = 0 + iindx(:) = 0 + xindx(:) = 0 + amerge(:) = .true. + imerge(:) = .true. + xmerge(:) = .true. + + do kof = 1,noflds + call getfld(kof, x2o_o, field_ocn, itemc_ocn) + if (field_ocn(1:2) == 'PF') then + cycle ! if flux has first character as P, pass straight through + end if + if (field_ocn(1:1) == 'S' .and. field_ocn(2:2) /= 'x') then + cycle ! ignore all ocn states that do not have a Sx_ prefix + end if + if (trim(field_ocn) == 'Foxx_swnet'.or. & + trim(field_ocn) == 'Faxa_snow' .or. & + trim(field_ocn) == 'Faxa_rain' .or. & + trim(field_ocn) == 'Faxa_prec') then + cycle ! ignore swnet, snow, rain, prec - treated explicitly above + end if + !wiso + if (trim(field_ocn) == 'Faxa_snow_16O' .or. & + trim(field_ocn) == 'Faxa_rain_16O' .or. & + trim(field_ocn) == 'Faxa_prec_16O' .or. & + trim(field_ocn) == 'Faxa_snow_18O' .or. & + trim(field_ocn) == 'Faxa_rain_18O' .or. & + trim(field_ocn) == 'Faxa_prec_18O' .or. & + trim(field_ocn) == 'Faxa_snow_HDO' .or. & + trim(field_ocn) == 'Faxa_rain_HDO' .or. & + trim(field_ocn) == 'Faxa_prec_HDO') then + cycle ! ignore iso snow, rain, prec - treated explicitly above + end if + if (trim(field_ocn(1:5)) == 'Forr_') then + cycle ! ignore runoff fields from land - treated in coupler + end if + + do kaf = 1,naflds + call getfld(kaf, a2x_o, field_atm, itemc_atm) + if (trim(itemc_ocn) == trim(itemc_atm)) then + if ((trim(field_ocn) == trim(field_atm))) then + if (field_atm(1:1) == 'F') amerge(kof) = .false. + end if + aindx(kof) = kaf + exit + end if + end do + do kif = 1,niflds + call getfld(kif, i2x_o, field_ice, itemc_ice) + if (field_ice(1:1) == 'F' .and. field_ice(2:4) == 'aii') then + cycle ! ignore all i2x_o fluxes that are ice/atm fluxes + end if + if (trim(itemc_ocn) == trim(itemc_ice)) then + if ((trim(field_ocn) == trim(field_ice))) then + if (field_ice(1:1) == 'F') imerge(kof) = .false. + end if + iindx(kof) = kif + exit + end if + end do + do kxf = 1,nxflds + call getfld(kxf, xao_o, field_xao, itemc_xao) + if (trim(itemc_ocn) == trim(itemc_xao)) then + if ((trim(field_ocn) == trim(field_xao))) then + if (field_xao(1:1) == 'F') xmerge(kof) = .false. + end if + xindx(kof) = kxf + exit + end if + end do + if (aindx(kof) == 0) itemc_atm = 'unset' + if (iindx(kof) == 0) itemc_ice = 'unset' + if (xindx(kof) == 0) itemc_xao = 'unset' + + if (iamroot) then + write(logunit,10)trim(itemc_ocn),& + trim(itemc_xao),trim(itemc_ice),trim(itemc_atm) +10 format(' ',' ocn field: ',a15,', xao merge: ',a15, & + ', ice merge: ',a15,', atm merge: ',a15) + write(logunit, *)'field_ocn,kof,imerge,amerge,xmerge= ',& + trim(field_ocn),kof,imerge(kof),xmerge(kof),amerge(kof) + end if + end do + + first_time = .false. + end if + + call seq_cdata_setptrs(cdata_o, infodata=infodata) + call seq_infodata_GetData(infodata, flux_epbalfact = flux_epbalfact) + + call mct_aVect_zero(x2o_o) + + call mct_aVect_copy(aVin=a2x_o, aVout=x2o_o, vector=mct_usevector) + call mct_aVect_copy(aVin=i2x_o, aVout=x2o_o, vector=mct_usevector) + call mct_aVect_copy(aVin=w2x_o, aVout=x2o_o, vector=mct_usevector) + call mct_aVect_copy(aVin=xao_o, aVout=x2o_o, vector=mct_usevector) + + ! Compute input ocn state (note that this only applies to non-land portion of gridcell) + + ki = mct_aVect_indexRa(fractions_o,"ifrac",perrWith=subName) + ko = mct_aVect_indexRa(fractions_o,"ofrac",perrWith=subName) + kir = mct_aVect_indexRa(fractions_o,"ifrad",perrWith=subName) + kor = mct_aVect_indexRa(fractions_o,"ofrad",perrWith=subName) + lsize = mct_aVect_lsize(x2o_o) + do n = 1,lsize + + ifrac = fractions_o%rAttr(ki,n) + afrac = fractions_o%rAttr(ko,n) + frac_sum = ifrac + afrac + if ((frac_sum) /= 0._r8) then + ifrac = ifrac / (frac_sum) + afrac = afrac / (frac_sum) + endif + + ifracr = fractions_o%rAttr(kir,n) + afracr = fractions_o%rAttr(kor,n) + frac_sum = ifracr + afracr + if ((frac_sum) /= 0._r8) then + ifracr = ifracr / (frac_sum) + afracr = afracr / (frac_sum) + endif + + ! Derived: compute net short-wave + avsdr = xao_o%rAttr(index_xao_So_avsdr,n) + anidr = xao_o%rAttr(index_xao_So_anidr,n) + avsdf = xao_o%rAttr(index_xao_So_avsdf,n) + anidf = xao_o%rAttr(index_xao_So_anidf,n) + fswabsv = a2x_o%rAttr(index_a2x_Faxa_swvdr,n) * (1.0_R8 - avsdr) & + + a2x_o%rAttr(index_a2x_Faxa_swvdf,n) * (1.0_R8 - avsdf) + fswabsi = a2x_o%rAttr(index_a2x_Faxa_swndr,n) * (1.0_R8 - anidr) & + + a2x_o%rAttr(index_a2x_Faxa_swndf,n) * (1.0_R8 - anidf) + x2o_o%rAttr(index_x2o_Foxx_swnet,n) = (fswabsv + fswabsi) * afracr + & + i2x_o%rAttr(index_i2x_Fioi_swpen,n) * ifrac + + ! Derived: compute total precipitation - scale total precip + ! Note that runoff is scaled by flux_epbalfact in ccsm_comp_mod + x2o_o%rAttr(index_x2o_Faxa_snow ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow ,n) = x2o_o%rAttr(index_x2o_Faxa_snow ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain ,n) = x2o_o%rAttr(index_x2o_Faxa_rain ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec ,n) = x2o_o%rAttr(index_x2o_Faxa_rain ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow ,n) + + !wiso + if ( flds_wiso )then + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_16O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_16O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_16O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_16O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_18O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_18O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_18O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_18O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_HDO,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_HDO,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_HDO,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_HDO,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) + x2o_o%rAttr(index_x2o_Faxa_prec_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) + x2o_o%rAttr(index_x2o_Faxa_prec_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) + end if + + end do + + do kof = 1,noflds + do n = 1,lsize + ifrac = fractions_o%rAttr(ki,n) + afrac = fractions_o%rAttr(ko,n) + frac_sum = ifrac + afrac + if ((frac_sum) /= 0._r8) then + ifrac = ifrac / (frac_sum) + afrac = afrac / (frac_sum) + endif + if (iindx(kof) > 0) then + if (imerge(kof)) then + x2o_o%rAttr(kof,n) = x2o_o%rAttr(kof,n) + i2x_o%rAttr(iindx(kof),n) * ifrac + else + x2o_o%rAttr(kof,n) = i2x_o%rAttr(iindx(kof),n) * ifrac + end if + end if + if (aindx(kof) > 0) then + if (amerge(kof)) then + x2o_o%rAttr(kof,n) = x2o_o%rAttr(kof,n) + a2x_o%rAttr(aindx(kof),n) * afrac + else + x2o_o%rAttr(kof,n) = a2x_o%rAttr(aindx(kof),n) * afrac + end if + end if + if (xindx(kof) > 0) then + if (xmerge(kof)) then + x2o_o%rAttr(kof,n) = x2o_o%rAttr(kof,n) + xao_o%rAttr(xindx(kof),n) * afrac + else + x2o_o%rAttr(kof,n) = xao_o%rAttr(xindx(kof),n) * afrac + end if + end if + end do + end do + + end subroutine mrg_x2o_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2g_run_mct( cdata_g, s2x_g, x2g_g ) + + !----------------------------------------------------------------------- + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_g + type(mct_aVect), intent(inout) :: s2x_g ! input + type(mct_aVect), intent(inout) :: x2g_g ! output + !----------------------------------------------------------------------- + + ! Create input glc state directly from land snow output state + call mct_aVect_copy(aVin=s2x_g, aVout=x2g_g, vector=mct_usevector) + + end subroutine mrg_x2g_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2s_run_mct( cdata_s, g2x_s, x2s_s ) + + !----------------------------------------------------------------------- + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_s + type(mct_aVect), intent(inout) :: g2x_s ! input + type(mct_aVect), intent(inout) :: x2s_s ! output + !----------------------------------------------------------------------- + + ! Create input land state directly from glc output state + call mct_aVect_copy(aVin=g2x_s, aVout=x2s_s, vector=mct_usevector) + + end subroutine mrg_x2s_run_mct + +!-------------------------------------------------------------------------- + + subroutine mrg_x2w_run_mct( cdata_w, a2x_w, o2x_w, i2x_w, frac_w, x2w_w) + + !----------------------------------------------------------------------- + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_w + type(mct_aVect), intent(inout) :: a2x_w ! input + type(mct_aVect), intent(inout) :: o2x_w ! input + type(mct_aVect), intent(inout) :: i2x_w ! input + type(mct_aVect), intent(inout) :: frac_w ! input + type(mct_aVect), intent(inout) :: x2w_w ! output + !----------------------------------------------------------------------- + + ! Create input wave state directly from atm, ocn, ice output state + + call mct_aVect_copy(aVin=a2x_w, aVout=x2w_w, vector=mct_usevector) + call mct_aVect_copy(aVin=o2x_w, aVout=x2w_w, vector=mct_usevector) + call mct_aVect_copy(aVin=i2x_w, aVout=x2w_w, vector=mct_usevector) + + end subroutine mrg_x2w_run_mct + +!-------------------------------------------------------------------------- + + subroutine getfld(n, av, field, suffix) + integer , intent(in) :: n + type(mct_aVect) , intent(in) :: av + character(len=*), intent(out) :: field + character(len=*), intent(out) :: suffix + + type(mct_string) :: mstring ! mct char type + + call mct_aVect_getRList(mstring,n,av) + field = mct_string_toChar(mstring) + suffix = trim(field(scan(field,'_'):)) + call mct_string_clean(mstring) + + if (field(1:1) /= 'S' .and. field(1:1) /= 'F' .and. field(1:2) /= 'PF') then + write(6,*)'field attribute',trim(field),' must start with S or F or PF' + call shr_sys_abort() + end if + end subroutine getfld + +end module mrg_mod diff --git a/driver-mct/main/prep_aoflux_mod.F90 b/driver-mct/main/prep_aoflux_mod.F90 new file mode 100644 index 000000000000..2c0917da22da --- /dev/null +++ b/driver-mct/main/prep_aoflux_mod.F90 @@ -0,0 +1,213 @@ +module prep_aoflux_mod + + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use seq_comm_mct, only: num_inst_xao, num_inst_frc, num_inst_ocn + use seq_comm_mct, only: CPLID, logunit + use seq_comm_mct, only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_getdata, seq_infodata_type + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: atm, ocn + + implicit none + private ! except + save + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_aoflux_init + + public :: prep_aoflux_calc_xao_ox + public :: prep_aoflux_calc_xao_ax + + public :: prep_aoflux_get_xao_ox + public :: prep_aoflux_get_xao_ax + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! attribute vectors + type(mct_aVect), pointer :: xao_ox(:) ! Atm-ocn fluxes, ocn grid, cpl pes + type(mct_aVect), pointer :: xao_ax(:) ! Atm-ocn fluxes, atm grid, cpl pes + + ! seq_comm_getData variables + logical :: iamroot_CPLID ! .true. => CPLID masterproc + integer :: mpicom_CPLID ! MPI cpl communicator + + ! seq_infodata_getData variables + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_aoflux_init (infodata, fractions_ox, fractions_ax) + + !--------------------------------------------------------------- + ! Description + ! Initialize atm/ocn flux component and compute ocean albedos + ! module variables + ! + ! Arguments + type (seq_infodata_type) , intent(inout) :: infodata + type(mct_aVect) , intent(in) :: fractions_ox(:) + type(mct_aVect) , intent(in) :: fractions_ax(:) + ! + ! Local Variables + integer :: exi , efi, eoi + integer :: lsize_o + integer :: lsize_a + character(SHR_KIND_CS) :: aoflux_grid ! grid for atm ocn flux calc + type(mct_avect) , pointer :: a2x_ax + type(mct_avect) , pointer :: o2x_ox + character(*) , parameter :: subname = '(prep_aoflux_init)' + !--------------------------------------------------------------- + + call seq_infodata_getdata(infodata, & + aoflux_grid=aoflux_grid) + + call seq_comm_getdata(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + a2x_ax => component_get_c2x_cx(atm(1)) + if (associated(a2x_ax)) then + lsize_a = mct_aVect_lsize(a2x_ax) + else + lsize_a = 0 + end if + + o2x_ox => component_get_c2x_cx(ocn(1)) + if (associated(o2x_ox)) then + lsize_o = mct_aVect_lsize(o2x_ox) + else + lsize_o = 0 + end if + + allocate(xao_ax(num_inst_xao)) + do exi = 1,num_inst_xao + call mct_aVect_init(xao_ax(exi), rList=seq_flds_xao_fields, lsize=lsize_a) + call mct_aVect_zero(xao_ax(exi)) + end do + allocate(xao_ox(num_inst_xao)) + do exi = 1,num_inst_xao + call mct_aVect_init(xao_ox(exi), rList=seq_flds_xao_fields, lsize=lsize_o) + call mct_aVect_zero(xao_ox(exi)) + enddo + + end subroutine prep_aoflux_init + + !================================================================================================ + + subroutine prep_aoflux_calc_xao_ax(fractions_ox, flds, timer) + !--------------------------------------------------------------- + ! Description + ! Create xao_ox + ! + ! Uses + use prep_atm_mod, only: prep_atm_get_mapper_So2a + use prep_atm_mod, only: prep_atm_get_mapper_Fo2a + ! + ! Arguments + type(mct_aVect) , intent(in) :: fractions_ox(:) + character(len=*), intent(in) :: flds + character(len=*), intent(in) :: timer + ! + ! Local Variables + type(seq_map) , pointer :: mapper_So2a + type(seq_map) , pointer :: mapper_Fo2a + integer :: exi, efi + character(*), parameter :: subname = '(prep_aoflux_calc_xao_ax)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + if (trim(flds) == 'albedos') then + do exi = 1,num_inst_xao + efi = mod((exi-1),num_inst_frc) + 1 + + mapper_So2a => prep_atm_get_mapper_So2a() + call seq_map_map(mapper_So2a, xao_ox(exi), xao_ax(exi), & + fldlist=seq_flds_xao_albedo, norm=.true., & + avwts_s=fractions_ox(efi),avwtsfld_s='ofrac') + enddo + end if + + if (trim(flds) == 'states_and_fluxes') then + do exi = 1,num_inst_xao + efi = mod((exi-1),num_inst_frc) + 1 + + mapper_So2a => prep_atm_get_mapper_So2a() + call seq_map_map(mapper_So2a, xao_ox(exi), xao_ax(exi), & + fldlist=seq_flds_xao_states, norm=.true., & + avwts_s=fractions_ox(efi),avwtsfld_s='ofrac') + + mapper_Fo2a => prep_atm_get_mapper_Fo2a() + call seq_map_map(mapper_Fo2a, xao_ox(exi), xao_ax(exi),& + fldlist=seq_flds_xao_fluxes, norm=.true., & + avwts_s=fractions_ox(efi),avwtsfld_s='ofrac') + enddo + end if + call t_drvstopf (trim(timer)) + + end subroutine prep_aoflux_calc_xao_ax + + !================================================================================================ + + subroutine prep_aoflux_calc_xao_ox(timer) + !--------------------------------------------------------------- + ! Description + ! Create xao_ox + ! + ! Uses + use prep_ocn_mod, only: prep_ocn_get_mapper_Fa2o + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + type(seq_map), pointer :: mapper_Fa2o + integer :: exi + character(*), parameter :: subname = '(prep_aoflux_calc_xao_ax)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + ! this mapping has to be done with area overlap mapping for all fields + ! due to the masking of the xao_ax data and the fact that a2oS is bilinear + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do exi = 1,num_inst_xao +! if (iamroot_CPLID .and. exi == 1) then +! write(logunit,F00) 'Calling map_atm2ocn_mct for mapping xao_ax to xao_ox' +! end if + + mapper_Fa2o => prep_ocn_get_mapper_Fa2o() + call seq_map_map(mapper_Fa2o, xao_ax(exi), xao_ox(exi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_aoflux_calc_xao_ox + + !================================================================================================ + + function prep_aoflux_get_xao_ox() + type(mct_aVect), pointer :: prep_aoflux_get_xao_ox(:) + prep_aoflux_get_xao_ox => xao_ox(:) + end function prep_aoflux_get_xao_ox + + function prep_aoflux_get_xao_ax() + type(mct_aVect), pointer :: prep_aoflux_get_xao_ax(:) + prep_aoflux_get_xao_ax => xao_ax(:) + end function prep_aoflux_get_xao_ax + +end module prep_aoflux_mod diff --git a/driver-mct/main/prep_atm_mod.F90 b/driver-mct/main/prep_atm_mod.F90 new file mode 100644 index 000000000000..c4836f344078 --- /dev/null +++ b/driver-mct/main/prep_atm_mod.F90 @@ -0,0 +1,790 @@ +module prep_atm_mod + + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use seq_comm_mct, only: num_inst_atm, num_inst_ocn, num_inst_ice, num_inst_lnd, num_inst_xao, & + num_inst_frc, num_inst_max, CPLID, ATMID, logunit + use seq_comm_mct, only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: atm, lnd, ocn, ice + + implicit none + save + PRIVATE + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_atm_init + public :: prep_atm_mrg + + public :: prep_atm_get_l2x_ax + public :: prep_atm_get_i2x_ax + public :: prep_atm_get_o2x_ax + + public :: prep_atm_calc_l2x_ax + public :: prep_atm_calc_i2x_ax + public :: prep_atm_calc_o2x_ax + + public :: prep_atm_get_mapper_So2a + public :: prep_atm_get_mapper_Fo2a + public :: prep_atm_get_mapper_Sl2a + public :: prep_atm_get_mapper_Fl2a + public :: prep_atm_get_mapper_Si2a + public :: prep_atm_get_mapper_Fi2a + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_atm_merge + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_So2a + type(seq_map), pointer :: mapper_Sl2a + type(seq_map), pointer :: mapper_Si2a + type(seq_map), pointer :: mapper_Fo2a ! needed for seq_frac_init + type(seq_map), pointer :: mapper_Fl2a ! needed for seq_frac_init + type(seq_map), pointer :: mapper_Fi2a ! needed for seq_frac_init + + ! attribute vectors + type(mct_aVect), pointer :: l2x_ax(:) ! Lnd export, atm grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: i2x_ax(:) ! Ice export, atm grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: o2x_ax(:) ! Ocn export, atm grid, cpl pes - allocated in driver + + ! other module variables + integer :: mpicom_CPLID ! MPI cpl communicator + logical :: iamroot_CPLID ! .true. => CPLID masterproc + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_atm_init(infodata, ocn_c2_atm, ice_c2_atm, lnd_c2_atm) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and mappers + ! + ! Arguments + type (seq_infodata_type) , intent(inout) :: infodata + logical , intent(in) :: ocn_c2_atm ! .true. => ocn to atm coupling on + logical , intent(in) :: ice_c2_atm ! .true. => ice to atm coupling on + logical , intent(in) :: lnd_c2_atm ! .true. => lnd to atm coupling on + ! + ! Local Variables + integer :: lsize_a + integer :: eli, eoi, eii, eai, emi + integer :: ka,km,k1,k2,k3 ! aVect field indices + logical :: samegrid_ao ! samegrid atm and ocean + logical :: samegrid_al ! samegrid atm and land + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: atm_present ! .true. => atm is present + logical :: ocn_present ! .true. => ocn is present + logical :: ice_present ! .true. => ice is present + logical :: lnd_present ! .true. => lnd is prsent + character(CL) :: ocn_gnam ! ocn grid + character(CL) :: atm_gnam ! atm grid + character(CL) :: lnd_gnam ! lnd grid + type(mct_avect), pointer :: a2x_ax + character(*), parameter :: subname = '(prep_atm_init)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + atm_present=atm_present, & + ocn_present=ocn_present, & + ice_present=ice_present, & + lnd_present=lnd_present, & + atm_gnam=atm_gnam, & + ocn_gnam=ocn_gnam, & + lnd_gnam=lnd_gnam, & + esmf_map_flag=esmf_map_flag) + + allocate(mapper_So2a) + allocate(mapper_Sl2a) + allocate(mapper_Si2a) + allocate(mapper_Fo2a) + allocate(mapper_Fl2a) + allocate(mapper_Fi2a) + + if (atm_present) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + a2x_ax => component_get_c2x_cx(atm(1)) + lsize_a = mct_aVect_lsize(a2x_ax) + + allocate(l2x_ax(num_inst_lnd)) + do eli = 1,num_inst_lnd + call mct_aVect_init(l2x_ax(eli), rList=seq_flds_l2x_fields, lsize=lsize_a) + call mct_aVect_zero(l2x_ax(eli)) + end do + allocate(o2x_ax(num_inst_max)) + do emi = 1,num_inst_max + call mct_aVect_init(o2x_ax(emi), rList=seq_flds_o2x_fields, lsize=lsize_a) + call mct_aVect_zero(o2x_ax(emi)) + enddo + allocate(i2x_ax(num_inst_ice)) + do eii = 1,num_inst_ice + call mct_aVect_init(i2x_ax(eii), rList=seq_flds_i2x_fields, lsize=lsize_a) + call mct_aVect_zero(i2x_ax(eii)) + enddo + + samegrid_al = .true. + samegrid_ao = .true. + if (trim(atm_gnam) /= trim(lnd_gnam)) samegrid_al = .false. + if (trim(atm_gnam) /= trim(ocn_gnam)) samegrid_ao = .false. + + if (ocn_c2_atm) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_So2a' + end if + call seq_map_init_rcfile(mapper_So2a, ocn(1), atm(1), & + 'seq_maps.rc','ocn2atm_smapname:','ocn2atm_smaptype:',samegrid_ao, & + 'mapper_So2a initialization',esmf_map_flag) + end if + + ! needed for domain checking + if (ocn_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fo2a' + end if + call seq_map_init_rcfile(mapper_Fo2a, ocn(1), atm(1), & + 'seq_maps.rc','ocn2atm_fmapname:','ocn2atm_fmaptype:',samegrid_ao, & + 'mapper_Fo2a initialization',esmf_map_flag) + endif + call shr_sys_flush(logunit) + + if (ice_c2_atm) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Si2a' + end if + call seq_map_init_rcfile(mapper_Si2a, ice(1), atm(1), & + 'seq_maps.rc','ice2atm_smapname:','ice2atm_smaptype:',samegrid_ao, & + 'mapper_Si2a initialization',esmf_map_flag) + end if + + ! needed for domain checking + if (ice_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fi2a' + end if + call seq_map_init_rcfile(mapper_Fi2a, ice(1), atm(1), & + 'seq_maps.rc','ice2atm_fmapname:','ice2atm_fmaptype:',samegrid_ao, & + 'mapper_Fi2a initialization',esmf_map_flag) + endif + call shr_sys_flush(logunit) + + ! needed for domain checking + if (lnd_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fl2a' + end if + call seq_map_init_rcfile(mapper_Fl2a, lnd(1), atm(1), & + 'seq_maps.rc','lnd2atm_fmapname:','lnd2atm_fmaptype:',samegrid_al, & + 'mapper_Fl2a initialization',esmf_map_flag) + endif + call shr_sys_flush(logunit) + + if (lnd_c2_atm) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sl2a' + end if + call seq_map_init_rcfile(mapper_Sl2a, lnd(1), atm(1), & + 'seq_maps.rc','lnd2atm_smapname:','lnd2atm_smaptype:',samegrid_al, & + 'mapper_Sl2a initialization',esmf_map_flag) + end if + + + end if + + end subroutine prep_atm_init + + !================================================================================================ + + subroutine prep_atm_mrg(infodata, fractions_ax, xao_ax, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Prepare run phase, including running the merge + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type(mct_aVect) , intent(in) :: fractions_ax(:) + type(mct_aVect) , intent(in) :: xao_ax(:) + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eli, eoi, eii, exi, efi, eai, emi + type(mct_avect), pointer :: x2a_ax + character(*), parameter :: subname = '(prep_atm_mrg)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_mrg),barrier=mpicom_CPLID) + do eai = 1,num_inst_atm + ! Use fortran mod to address ensembles in merge + eli = mod((eai-1),num_inst_lnd) + 1 + eoi = mod((eai-1),num_inst_ocn) + 1 + eii = mod((eai-1),num_inst_ice) + 1 + exi = mod((eai-1),num_inst_xao) + 1 + efi = mod((eai-1),num_inst_frc) + 1 + emi = mod((eai-1),num_inst_max) + 1 + + x2a_ax => component_get_x2c_cx(atm(eai)) ! This is actually modifying x2a_ax + call prep_atm_merge(l2x_ax(eli), o2x_ax(emi), xao_ax(exi), i2x_ax(eii), & + fractions_ax(efi), x2a_ax) + enddo + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_atm_mrg + + !================================================================================================ + + subroutine prep_atm_merge( l2x_a, o2x_a, xao_a, i2x_a, fractions_a, x2a_a ) + + !----------------------------------------------------------------------- + ! + ! Arguments + type(mct_aVect), intent(in) :: l2x_a + type(mct_aVect), intent(in) :: o2x_a + type(mct_aVect), intent(in) :: xao_a + type(mct_aVect), intent(in) :: i2x_a + type(mct_aVect), intent(in) :: fractions_a + type(mct_aVect), intent(inout) :: x2a_a + ! + ! Local workspace + real(r8) :: fracl, fraci, fraco + integer :: n,ka,ki,kl,ko,kx,kof,kif,klf,i,i1,o1 + integer :: lsize + integer :: index_x2a_Sf_lfrac + integer :: index_x2a_Sf_ifrac + integer :: index_x2a_Sf_ofrac + character(CL),allocatable :: field_atm(:) ! string converted to char + character(CL),allocatable :: field_lnd(:) ! string converted to char + character(CL),allocatable :: field_ice(:) ! string converted to char + character(CL),allocatable :: field_xao(:) ! string converted to char + character(CL),allocatable :: field_ocn(:) ! string converted to char + character(CL),allocatable :: itemc_atm(:) ! string converted to char + character(CL),allocatable :: itemc_lnd(:) ! string converted to char + character(CL),allocatable :: itemc_ice(:) ! string converted to char + character(CL),allocatable :: itemc_xao(:) ! string converted to char + character(CL),allocatable :: itemc_ocn(:) ! string converted to char + logical :: iamroot + character(CL),allocatable :: mrgstr(:) ! temporary string + logical, save :: first_time = .true. + type(mct_aVect_sharedindices),save :: l2x_sharedindices + type(mct_aVect_sharedindices),save :: o2x_sharedindices + type(mct_aVect_sharedindices),save :: i2x_sharedindices + type(mct_aVect_sharedindices),save :: xao_sharedindices + logical, pointer, save :: lmerge(:),imerge(:),xmerge(:),omerge(:) + integer, pointer, save :: lindx(:), iindx(:), oindx(:),xindx(:) + integer, save :: naflds, nlflds,niflds,noflds,nxflds + character(*), parameter :: subname = '(prep_atm_merge) ' + !----------------------------------------------------------------------- + ! + call seq_comm_getdata(CPLID, iamroot=iamroot) + + if (first_time) then + + naflds = mct_aVect_nRattr(x2a_a) + nlflds = mct_aVect_nRattr(l2x_a) + niflds = mct_aVect_nRattr(i2x_a) + noflds = mct_aVect_nRattr(o2x_a) + nxflds = mct_aVect_nRattr(xao_a) + + allocate(lindx(naflds), lmerge(naflds)) + allocate(iindx(naflds), imerge(naflds)) + allocate(xindx(naflds), xmerge(naflds)) + allocate(oindx(naflds), omerge(naflds)) + allocate(field_atm(naflds), itemc_atm(naflds)) + allocate(field_lnd(nlflds), itemc_lnd(nlflds)) + allocate(field_ice(niflds), itemc_ice(niflds)) + allocate(field_ocn(noflds), itemc_ocn(noflds)) + allocate(field_xao(nxflds), itemc_xao(nxflds)) + allocate(mrgstr(naflds)) + + lindx(:) = 0 + iindx(:) = 0 + xindx(:) = 0 + oindx(:) = 0 + lmerge(:) = .true. + imerge(:) = .true. + xmerge(:) = .true. + omerge(:) = .true. + + do ka = 1,naflds + field_atm(ka) = mct_aVect_getRList2c(ka, x2a_a) + itemc_atm(ka) = trim(field_atm(ka)(scan(field_atm(ka),'_'):)) + enddo + do kl = 1,nlflds + field_lnd(kl) = mct_aVect_getRList2c(kl, l2x_a) + itemc_lnd(kl) = trim(field_lnd(kl)(scan(field_lnd(kl),'_'):)) + enddo + do ki = 1,niflds + field_ice(ki) = mct_aVect_getRList2c(ki, i2x_a) + itemc_ice(ki) = trim(field_ice(ki)(scan(field_ice(ki),'_'):)) + enddo + do ko = 1,noflds + field_ocn(ko) = mct_aVect_getRList2c(ko, o2x_a) + itemc_ocn(ko) = trim(field_ocn(ko)(scan(field_ocn(ko),'_'):)) + enddo + do kx = 1,nxflds + field_xao(kx) = mct_aVect_getRList2c(kx, xao_a) + itemc_xao(kx) = trim(field_xao(kx)(scan(field_xao(kx),'_'):)) + enddo + + call mct_aVect_setSharedIndices(l2x_a, x2a_a, l2x_SharedIndices) + call mct_aVect_setSharedIndices(o2x_a, x2a_a, o2x_SharedIndices) + call mct_aVect_setSharedIndices(i2x_a, x2a_a, i2x_SharedIndices) + call mct_aVect_setSharedIndices(xao_a, x2a_a, xao_SharedIndices) + + ! Field naming rules + ! Only atm states that are Sx_... will be merged + ! Only fluxes that are F??x_... will be merged + ! All fluxes will be multiplied by corresponding component fraction + + do ka = 1,naflds + !--- document merge --- + mrgstr(ka) = subname//'x2a%'//trim(field_atm(ka))//' =' + if (field_atm(ka)(1:2) == 'PF') then + cycle ! if flux has first character as P, pass straight through + end if + if (field_atm(ka)(1:1) == 'S' .and. field_atm(ka)(2:2) /= 'x') then + cycle ! any state fields that are not Sx_ will just be copied + end if + + do kl = 1,nlflds + if (trim(itemc_atm(ka)) == trim(itemc_lnd(kl))) then + if ((trim(field_atm(ka)) == trim(field_lnd(kl)))) then + if (field_lnd(kl)(1:1) == 'F') lmerge(ka) = .false. + end if + ! --- make sure only one field matches --- + if (lindx(ka) /= 0) then + write(logunit,*) subname,' ERROR: found multiple kl field matches for ',trim(itemc_lnd(kl)) + call shr_sys_abort(subname//' ERROR multiple kl field matches') + endif + lindx(ka) = kl + end if + end do + do ki = 1,niflds + if (field_ice(ki)(1:1) == 'F' .and. field_ice(ki)(2:4) == 'ioi') then + cycle ! ignore all fluxes that are ice/ocn fluxes + end if + if (trim(itemc_atm(ka)) == trim(itemc_ice(ki))) then + if ((trim(field_atm(ka)) == trim(field_ice(ki)))) then + if (field_ice(ki)(1:1) == 'F') imerge(ka) = .false. + end if + ! --- make sure only one field matches --- + if (iindx(ka) /= 0) then + write(logunit,*) subname,' ERROR: found multiple ki field matches for ',trim(itemc_ice(ki)) + call shr_sys_abort(subname//' ERROR multiple ki field matches') + endif + iindx(ka) = ki + end if + end do + do kx = 1,nxflds + if (trim(itemc_atm(ka)) == trim(itemc_xao(kx))) then + if ((trim(field_atm(ka)) == trim(field_xao(kx)))) then + if (field_xao(kx)(1:1) == 'F') xmerge(ka) = .false. + end if + ! --- make sure only one field matches --- + if (xindx(ka) /= 0) then + write(logunit,*) subname,' ERROR: found multiple kx field matches for ',trim(itemc_xao(kx)) + call shr_sys_abort(subname//' ERROR multiple kx field matches') + endif + xindx(ka) = kx + end if + end do + do ko = 1,noflds + if (trim(itemc_atm(ka)) == trim(itemc_ocn(ko))) then + if ((trim(field_atm(ka)) == trim(field_ocn(ko)))) then + if (field_ocn(ko)(1:1) == 'F') omerge(ka) = .false. + end if + ! --- make sure only one field matches --- + if (oindx(ka) /= 0) then + write(logunit,*) subname,' ERROR: found multiple ko field matches for ',trim(itemc_ocn(ko)) + call shr_sys_abort(subname//' ERROR multiple ko field matches') + endif + oindx(ka) = ko + end if + end do + + ! --- add some checks --- + + ! --- make sure all terms agree on merge or non-merge aspect --- + if (oindx(ka) > 0 .and. xindx(ka) > 0) then + write(logunit,*) subname,' ERROR: oindx and xindx both non-zero, not allowed ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR oindx and xindx both non-zero') + endif + + ! --- make sure all terms agree on merge or non-merge aspect --- + if (lindx(ka) > 0 .and. iindx(ka) > 0 .and. (lmerge(ka) .neqv. imerge(ka))) then + write(logunit,*) subname,' ERROR: lindx and iindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR lindx and iindx merge logic error') + endif + if (lindx(ka) > 0 .and. xindx(ka) > 0 .and. (lmerge(ka) .neqv. xmerge(ka))) then + write(logunit,*) subname,' ERROR: lindx and xindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR lindx and xindx merge logic error') + endif + if (lindx(ka) > 0 .and. oindx(ka) > 0 .and. (lmerge(ka) .neqv. omerge(ka))) then + write(logunit,*) subname,' ERROR: lindx and oindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR lindx and oindx merge logic error') + endif + if (xindx(ka) > 0 .and. iindx(ka) > 0 .and. (xmerge(ka) .neqv. imerge(ka))) then + write(logunit,*) subname,' ERROR: xindx and iindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR xindx and iindx merge logic error') + endif + if (xindx(ka) > 0 .and. oindx(ka) > 0 .and. (xmerge(ka) .neqv. omerge(ka))) then + write(logunit,*) subname,' ERROR: xindx and oindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR xindx and oindx merge logic error') + endif + if (iindx(ka) > 0 .and. oindx(ka) > 0 .and. (imerge(ka) .neqv. omerge(ka))) then + write(logunit,*) subname,' ERROR: iindx and oindx merge logic error ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR iindx and oindx merge logic error') + endif + + end do + end if + + ! Zero attribute vector + + call mct_avect_zero(x2a_a) + + ! Update surface fractions + + kif=mct_aVect_indexRA(fractions_a,"ifrac") + klf=mct_aVect_indexRA(fractions_a,"lfrac") + kof=mct_aVect_indexRA(fractions_a,"ofrac") + lsize = mct_avect_lsize(x2a_a) + + index_x2a_Sf_lfrac = mct_aVect_indexRA(x2a_a,'Sf_lfrac') + index_x2a_Sf_ifrac = mct_aVect_indexRA(x2a_a,'Sf_ifrac') + index_x2a_Sf_ofrac = mct_aVect_indexRA(x2a_a,'Sf_ofrac') + do n = 1,lsize + x2a_a%rAttr(index_x2a_Sf_lfrac,n) = fractions_a%Rattr(klf,n) + x2a_a%rAttr(index_x2a_Sf_ifrac,n) = fractions_a%Rattr(kif,n) + x2a_a%rAttr(index_x2a_Sf_ofrac,n) = fractions_a%Rattr(kof,n) + end do + + !--- document fraction operations --- + if (first_time) then + mrgstr(index_x2a_sf_lfrac) = trim(mrgstr(index_x2a_sf_lfrac))//' = fractions_a%lfrac' + mrgstr(index_x2a_sf_ifrac) = trim(mrgstr(index_x2a_sf_ifrac))//' = fractions_a%ifrac' + mrgstr(index_x2a_sf_ofrac) = trim(mrgstr(index_x2a_sf_ofrac))//' = fractions_a%ofrac' + endif + + ! Copy attributes that do not need to be merged + ! These are assumed to have the same name in + ! (o2x_a and x2a_a) and in (l2x_a and x2a_a), etc. + + !--- document copy operations --- + if (first_time) then + !--- document merge --- + do i=1,l2x_SharedIndices%shared_real%num_indices + i1=l2x_SharedIndices%shared_real%aVindices1(i) + o1=l2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = l2x%'//trim(field_lnd(i1)) + enddo + do i=1,o2x_SharedIndices%shared_real%num_indices + i1=o2x_SharedIndices%shared_real%aVindices1(i) + o1=o2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = o2x%'//trim(field_ocn(i1)) + enddo + do i=1,i2x_SharedIndices%shared_real%num_indices + i1=i2x_SharedIndices%shared_real%aVindices1(i) + o1=i2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = i2x%'//trim(field_ice(i1)) + enddo + do i=1,xao_SharedIndices%shared_real%num_indices + i1=xao_SharedIndices%shared_real%aVindices1(i) + o1=xao_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = xao%'//trim(field_xao(i1)) + enddo + endif + +! call mct_aVect_copy(aVin=l2x_a, aVout=x2a_a, vector=mct_usevector) +! call mct_aVect_copy(aVin=o2x_a, aVout=x2a_a, vector=mct_usevector) +! call mct_aVect_copy(aVin=i2x_a, aVout=x2a_a, vector=mct_usevector) +! call mct_aVect_copy(aVin=xao_a, aVout=x2a_a, vector=mct_usevector) + call mct_aVect_copy(aVin=l2x_a, aVout=x2a_a, vector=mct_usevector, sharedIndices=l2x_SharedIndices) + call mct_aVect_copy(aVin=o2x_a, aVout=x2a_a, vector=mct_usevector, sharedIndices=o2x_SharedIndices) + call mct_aVect_copy(aVin=i2x_a, aVout=x2a_a, vector=mct_usevector, sharedIndices=i2x_SharedIndices) + call mct_aVect_copy(aVin=xao_a, aVout=x2a_a, vector=mct_usevector, sharedIndices=xao_SharedIndices) + + ! If flux to atm is coming only from the ocean (based on field being in o2x_a) - + ! -- then scale by both ocean and ice fraction + ! If flux to atm is coming only from the land or ice or coupler + ! -- then do scale by fraction above + + do ka = 1,naflds + !--- document merge --- + if (first_time) then + if (lindx(ka) > 0) then + if (lmerge(ka)) then + mrgstr(ka) = trim(mrgstr(ka))//' + lfrac*l2x%'//trim(field_lnd(lindx(ka))) + else + mrgstr(ka) = trim(mrgstr(ka))//' = lfrac*l2x%'//trim(field_lnd(lindx(ka))) + end if + end if + if (iindx(ka) > 0) then + if (imerge(ka)) then + mrgstr(ka) = trim(mrgstr(ka))//' + ifrac*i2x%'//trim(field_ice(iindx(ka))) + else + mrgstr(ka) = trim(mrgstr(ka))//' = ifrac*i2x%'//trim(field_ice(iindx(ka))) + end if + end if + if (xindx(ka) > 0) then + if (xmerge(ka)) then + mrgstr(ka) = trim(mrgstr(ka))//' + ofrac*xao%'//trim(field_xao(xindx(ka))) + else + mrgstr(ka) = trim(mrgstr(ka))//' = ofrac*xao%'//trim(field_xao(xindx(ka))) + end if + end if + if (oindx(ka) > 0) then + if (omerge(ka)) then + mrgstr(ka) = trim(mrgstr(ka))//' + ofrac*o2x%'//trim(field_ocn(oindx(ka))) + end if + if (.not. omerge(ka)) then + mrgstr(ka) = trim(mrgstr(ka))//' + (ifrac+ofrac)*o2x%'//trim(field_ocn(oindx(ka))) + end if + end if + endif + + do n = 1,lsize + fracl = fractions_a%Rattr(klf,n) + fraci = fractions_a%Rattr(kif,n) + fraco = fractions_a%Rattr(kof,n) + if (lindx(ka) > 0 .and. fracl > 0._r8) then + if (lmerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + l2x_a%rAttr(lindx(ka),n) * fracl + else + x2a_a%rAttr(ka,n) = l2x_a%rAttr(lindx(ka),n) * fracl + end if + end if + if (iindx(ka) > 0 .and. fraci > 0._r8) then + if (imerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + i2x_a%rAttr(iindx(ka),n) * fraci + else + x2a_a%rAttr(ka,n) = i2x_a%rAttr(iindx(ka),n) * fraci + end if + end if + if (xindx(ka) > 0 .and. fraco > 0._r8) then + if (xmerge(ka)) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + xao_a%rAttr(xindx(ka),n) * fraco + else + x2a_a%rAttr(ka,n) = xao_a%rAttr(xindx(ka),n) * fraco + end if + end if + if (oindx(ka) > 0) then + if (omerge(ka) .and. fraco > 0._r8) then + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + o2x_a%rAttr(oindx(ka),n) * fraco + end if + if (.not. omerge(ka)) then + !--- NOTE: This IS using the ocean fields and ice fraction !! --- + x2a_a%rAttr(ka,n) = o2x_a%rAttr(oindx(ka),n) * fraci + x2a_a%rAttr(ka,n) = x2a_a%rAttr(ka,n) + o2x_a%rAttr(oindx(ka),n) * fraco + end if + end if + end do + end do + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do ka = 1,naflds + write(logunit,'(A)') trim(mrgstr(ka)) + enddo + endif + deallocate(mrgstr) + deallocate(field_atm,itemc_atm) + deallocate(field_lnd,itemc_lnd) + deallocate(field_ice,itemc_ice) + deallocate(field_ocn,itemc_ocn) + deallocate(field_xao,itemc_xao) + endif + + first_time = .false. + + end subroutine prep_atm_merge + + !================================================================================================ + + subroutine prep_atm_calc_o2x_ax(fractions_ox, timer) + !--------------------------------------------------------------- + ! Description + ! Create o2x_ax (note that o2x_ax is a local module variable) + ! + ! Arguments + type(mct_aVect) , optional, intent(in) :: fractions_ox(:) + character(len=*), optional, intent(in) :: timer + ! + ! Local Variables + integer :: eoi, efi, emi + type(mct_aVect) , pointer :: o2x_ox + character(*), parameter :: subname = '(prep_atm_calc_o2x_ax)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do emi = 1,num_inst_max + eoi = mod((emi-1),num_inst_ocn) + 1 + efi = mod((emi-1),num_inst_frc) + 1 + + o2x_ox => component_get_c2x_cx(ocn(eoi)) + if (present(fractions_ox)) then + call seq_map_map(mapper_So2a, o2x_ox, o2x_ax(emi),& + fldlist=seq_flds_o2x_states,norm=.true., & + avwts_s=fractions_ox(efi),avwtsfld_s='ofrac') + else + call seq_map_map(mapper_So2a, o2x_ox, o2x_ax(emi),& + fldlist=seq_flds_o2x_states,norm=.true.) + endif + call seq_map_map(mapper_Fo2a, o2x_ox, o2x_ax(emi),& + fldlist=seq_flds_o2x_fluxes,norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_atm_calc_o2x_ax + + !================================================================================================ + + subroutine prep_atm_calc_i2x_ax(fractions_ix, timer) + !--------------------------------------------------------------- + ! Description + ! Create i2x_ax (note that i2x_ax is a local module variable) + ! + ! Arguments + type(mct_aVect) , intent(in) :: fractions_ix(:) + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eii, efi + type(mct_aVect) , pointer :: i2x_ix + character(*), parameter :: subname = '(prep_atm_calc_i2x_ax)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eii = 1,num_inst_ice + efi = mod((eii-1),num_inst_frc) + 1 + + i2x_ix => component_get_c2x_cx(ice(eii)) + call seq_map_map(mapper_Si2a, i2x_ix, i2x_ax(eii), & + fldlist=seq_flds_i2x_states, & + avwts_s=fractions_ix(eii), avwtsfld_s='ifrac') + call seq_map_map(mapper_Fi2a, i2x_ix, i2x_ax(eii), & + fldlist=seq_flds_i2x_fluxes, & + avwts_s=fractions_ix(eii), avwtsfld_s='ifrac') + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_atm_calc_i2x_ax + + !================================================================================================ + + subroutine prep_atm_calc_l2x_ax(fractions_lx, timer) + !--------------------------------------------------------------- + ! Description + ! Create l2x_ax (note that l2x_ax is a local module variable) + ! + ! Arguments + type(mct_aVect) , intent(in) :: fractions_lx(:) + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eli, efi + type(mct_avect), pointer :: l2x_lx + character(*), parameter :: subname = '(prep_atm_calc_l2x_ax)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eli = 1,num_inst_lnd + efi = mod((eli-1),num_inst_frc) + 1 + + l2x_lx => component_get_c2x_cx(lnd(eli)) + call seq_map_map(mapper_Sl2a, l2x_lx, l2x_ax(eli), & + fldlist=seq_flds_l2x_states, norm=.true., & + avwts_s=fractions_lx(efi), avwtsfld_s='lfrin') + call seq_map_map(mapper_Fl2a, l2x_lx, l2x_ax(eli), & + fldlist=seq_flds_l2x_fluxes, norm=.true., & + avwts_s=fractions_lx(efi), avwtsfld_s='lfrin') + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_atm_calc_l2x_ax + + !================================================================================================ + + function prep_atm_get_l2x_ax() + type(mct_aVect), pointer :: prep_atm_get_l2x_ax(:) + prep_atm_get_l2x_ax => l2x_ax(:) + end function prep_atm_get_l2x_ax + + function prep_atm_get_i2x_ax() + type(mct_aVect), pointer :: prep_atm_get_i2x_ax(:) + prep_atm_get_i2x_ax => i2x_ax(:) + end function prep_atm_get_i2x_ax + + function prep_atm_get_o2x_ax() + type(mct_aVect), pointer :: prep_atm_get_o2x_ax(:) + prep_atm_get_o2x_ax => o2x_ax(:) + end function prep_atm_get_o2x_ax + + function prep_atm_get_mapper_So2a() + type(seq_map), pointer :: prep_atm_get_mapper_So2a + prep_atm_get_mapper_So2a => mapper_So2a + end function prep_atm_get_mapper_So2a + + function prep_atm_get_mapper_Fo2a() + type(seq_map), pointer :: prep_atm_get_mapper_Fo2a + prep_atm_get_mapper_Fo2a => mapper_Fo2a + end function prep_atm_get_mapper_Fo2a + + function prep_atm_get_mapper_Sl2a() + type(seq_map), pointer :: prep_atm_get_mapper_Sl2a + prep_atm_get_mapper_Sl2a => mapper_Sl2a + end function prep_atm_get_mapper_Sl2a + + function prep_atm_get_mapper_Fl2a() + type(seq_map), pointer :: prep_atm_get_mapper_Fl2a + prep_atm_get_mapper_Fl2a => mapper_Fl2a + end function prep_atm_get_mapper_Fl2a + + function prep_atm_get_mapper_Si2a() + type(seq_map), pointer :: prep_atm_get_mapper_Si2a + prep_atm_get_mapper_Si2a => mapper_Si2a + end function prep_atm_get_mapper_Si2a + + function prep_atm_get_mapper_Fi2a() + type(seq_map), pointer :: prep_atm_get_mapper_Fi2a + prep_atm_get_mapper_Fi2a => mapper_Fi2a + end function prep_atm_get_mapper_Fi2a + + !================================================================================================ + +end module prep_atm_mod diff --git a/driver-mct/main/prep_glc_mod.F90 b/driver-mct/main/prep_glc_mod.F90 new file mode 100644 index 000000000000..bb020f68ee91 --- /dev/null +++ b/driver-mct/main/prep_glc_mod.F90 @@ -0,0 +1,1105 @@ +module prep_glc_mod + +#include "shr_assert.h" + use shr_kind_mod , only: r8 => SHR_KIND_R8 + use shr_kind_mod , only: cl => SHR_KIND_CL + use shr_sys_mod , only: shr_sys_abort, shr_sys_flush + use seq_comm_mct , only: num_inst_glc, num_inst_lnd, num_inst_frc + use seq_comm_mct , only: CPLID, GLCID, logunit + use seq_comm_mct , only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: component_get_dom_cx + use component_type_mod, only: glc, lnd + use glc_elevclass_mod, only : glc_get_num_elevation_classes, glc_elevclass_as_string + use glc_elevclass_mod, only : glc_all_elevclass_strings, GLC_ELEVCLASS_STRLEN + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_glc_init + public :: prep_glc_mrg + + public :: prep_glc_accum + public :: prep_glc_accum_avg + + public :: prep_glc_calc_l2x_gx + + public :: prep_glc_zero_fields + + public :: prep_glc_get_l2x_gx + public :: prep_glc_get_l2gacc_lx + public :: prep_glc_get_l2gacc_lx_cnt + public :: prep_glc_get_mapper_Sl2g + public :: prep_glc_get_mapper_Fl2g + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_glc_do_renormalize_smb + private :: prep_glc_set_g2x_lx_fields + private :: prep_glc_merge + private :: prep_glc_map_one_state_field_lnd2glc + private :: prep_glc_map_qice_conservative_lnd2glc + private :: prep_glc_renormalize_smb + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_Sl2g + type(seq_map), pointer :: mapper_Fl2g + type(seq_map), pointer :: mapper_Fg2l + + ! attribute vectors + type(mct_aVect), pointer :: l2x_gx(:) ! Lnd export, glc grid, cpl pes - allocated in driver + + ! accumulation variables + type(mct_aVect), pointer :: l2gacc_lx(:) ! Lnd export, lnd grid, cpl pes - allocated in driver + integer , target :: l2gacc_lx_cnt ! l2gacc_lx: number of time samples accumulated + + ! other module variables + integer :: mpicom_CPLID ! MPI cpl communicator + + ! Whether to renormalize the SMB for conservation. + ! Should be set to true for 2-way coupled runs with evolving ice sheets. + ! Does not need to be true for 1-way coupling. + logical :: smb_renormalize + + ! Name of flux field giving surface mass balance + character(len=*), parameter :: qice_fieldname = 'Flgl_qice' + + ! Names of some other fields + character(len=*), parameter :: Sg_frac_field = 'Sg_ice_covered' + character(len=*), parameter :: Sg_topo_field = 'Sg_topo' + character(len=*), parameter :: Sg_icemask_field = 'Sg_icemask' + + ! Fields needed in the g2x_lx attribute vector used as part of mapping qice from lnd to glc + character(len=:), allocatable :: g2x_lx_fields + + + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_glc_init(infodata, lnd_c2_glc) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and mapping variables + ! + ! Arguments + type (seq_infodata_type) , intent(inout) :: infodata + logical , intent(in) :: lnd_c2_glc ! .true. => lnd to glc coupling on + ! + ! Local Variables + integer :: eli, egi + integer :: lsize_l + integer :: lsize_g + logical :: samegrid_lg ! samegrid land and glc + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: iamroot_CPLID ! .true. => CPLID masterproc + logical :: glc_present ! .true. => glc is present + character(CL) :: lnd_gnam ! lnd grid + character(CL) :: glc_gnam ! glc grid + type(mct_avect), pointer :: l2x_lx + type(mct_avect), pointer :: x2g_gx + character(*), parameter :: subname = '(prep_glc_init)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata , & + esmf_map_flag=esmf_map_flag , & + glc_present=glc_present , & + lnd_gnam=lnd_gnam , & + glc_gnam=glc_gnam) + + allocate(mapper_Sl2g) + allocate(mapper_Fl2g) + allocate(mapper_Fg2l) + + smb_renormalize = prep_glc_do_renormalize_smb(infodata) + + if (glc_present .and. lnd_c2_glc) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + l2x_lx => component_get_c2x_cx(lnd(1)) + lsize_l = mct_aVect_lsize(l2x_lx) + + x2g_gx => component_get_x2c_cx(glc(1)) + lsize_g = mct_aVect_lsize(x2g_gx) + + allocate(l2x_gx(num_inst_lnd)) + allocate(l2gacc_lx(num_inst_lnd)) + do eli = 1,num_inst_lnd + call mct_aVect_init(l2x_gx(eli), rList=seq_flds_x2g_fields, lsize=lsize_g) + call mct_aVect_zero(l2x_gx(eli)) + + call mct_aVect_init(l2gacc_lx(eli), rList=seq_flds_l2x_fields_to_glc, lsize=lsize_l) + call mct_aVect_zero(l2gacc_lx(eli)) + enddo + l2gacc_lx_cnt = 0 + + if (lnd_c2_glc) then + + samegrid_lg = .true. + if (trim(lnd_gnam) /= trim(glc_gnam)) samegrid_lg = .false. + + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sl2g' + end if + call seq_map_init_rcfile(mapper_Sl2g, lnd(1), glc(1), & + 'seq_maps.rc', 'lnd2glc_smapname:', 'lnd2glc_smaptype:', samegrid_lg, & + 'mapper_Sl2g initialization', esmf_map_flag) + + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fl2g' + end if + call seq_map_init_rcfile(mapper_Fl2g, lnd(1), glc(1), & + 'seq_maps.rc', 'lnd2glc_fmapname:', 'lnd2glc_fmaptype:', samegrid_lg, & + 'mapper_Fl2g initialization', esmf_map_flag) + + ! We need to initialize our own Fg2l mapper because in some cases (particularly + ! TG compsets - dlnd forcing CISM) the system doesn't otherwise create a Fg2l + ! mapper. + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fg2l' + end if + call seq_map_init_rcfile(mapper_Fg2l, glc(1), lnd(1), & + 'seq_maps.rc', 'glc2lnd_fmapname:', 'glc2lnd_fmaptype:', samegrid_lg, & + 'mapper_Fg2l initialization', esmf_map_flag) + + call prep_glc_set_g2x_lx_fields() + end if + call shr_sys_flush(logunit) + + end if + + end subroutine prep_glc_init + + !================================================================================================ + + function prep_glc_do_renormalize_smb(infodata) result(do_renormalize_smb) + ! Returns a logical saying whether we should do the smb renormalization + logical :: do_renormalize_smb ! function return value + ! + ! Arguments + type (seq_infodata_type) , intent(in) :: infodata + + ! Local variables + character(len=cl) :: glc_renormalize_smb ! namelist option saying whether to do smb renormalization + logical :: glc_coupled_fluxes ! does glc send fluxes to other components? + logical :: lnd_prognostic ! is lnd a prognostic component? + + character(len=*), parameter :: subname = '(prep_glc_do_renormalize_smb)' + !--------------------------------------------------------------- + + call seq_infodata_getdata(infodata, & + glc_renormalize_smb = glc_renormalize_smb, & + glc_coupled_fluxes = glc_coupled_fluxes, & + lnd_prognostic = lnd_prognostic) + + select case (glc_renormalize_smb) + case ('on') + do_renormalize_smb = .true. + case ('off') + do_renormalize_smb = .false. + case ('on_if_glc_coupled_fluxes') + if (.not. lnd_prognostic) then + ! Do not renormalize if we're running glc with dlnd (T compsets): In this case + ! there is no feedback from glc to lnd, and conservation is not important + do_renormalize_smb = .false. + else if (.not. glc_coupled_fluxes) then + ! Do not renormalize if glc isn't sending fluxes to other components: In this + ! case conservation is not important + do_renormalize_smb = .false. + else + ! lnd_prognostic is true and glc_coupled_fluxes is true + do_renormalize_smb = .true. + end if + case default + write(logunit,*) subname,' ERROR: unknown value for glc_renormalize_smb: ', & + trim(glc_renormalize_smb) + call shr_sys_abort(subname//' ERROR: unknown value for glc_renormalize_smb') + end select + end function prep_glc_do_renormalize_smb + + !================================================================================================ + + subroutine prep_glc_set_g2x_lx_fields() + + !--------------------------------------------------------------- + ! Description + ! Sets the module-level g2x_lx_fields variable. + ! + ! This gives the fields needed in the g2x_lx attribute vector used as part of mapping + ! qice from lnd to glc. + ! + ! Local Variables + character(len=GLC_ELEVCLASS_STRLEN), allocatable :: all_elevclass_strings(:) + character(len=:), allocatable :: frac_fields + character(len=:), allocatable :: topo_fields + integer :: strlen + + ! 1 is probably enough, but use 10 to be safe, in case the length of the delimiter + ! changes + integer, parameter :: extra_len_for_list_merge = 10 + + character(len=*), parameter :: subname = '(prep_glc_set_g2x_lx_fields)' + !--------------------------------------------------------------- + + allocate(all_elevclass_strings(0:glc_get_num_elevation_classes())) + all_elevclass_strings = glc_all_elevclass_strings(include_zero = .true.) + frac_fields = shr_string_listFromSuffixes( & + suffixes = all_elevclass_strings, & + strBase = Sg_frac_field) + ! Sg_topo is not actually needed on the land grid in + ! prep_glc_map_qice_conservative_lnd2glc, but it is required by the current interface + ! for map_glc2lnd_ec. + topo_fields = shr_string_listFromSuffixes( & + suffixes = all_elevclass_strings, & + strBase = Sg_topo_field) + + strlen = len_trim(frac_fields) + len_trim(topo_fields) + extra_len_for_list_merge + allocate(character(len=strlen) :: g2x_lx_fields) + call shr_string_listMerge(frac_fields, topo_fields, g2x_lx_fields) + + end subroutine prep_glc_set_g2x_lx_fields + + + !================================================================================================ + + subroutine prep_glc_accum(timer) + + !--------------------------------------------------------------- + ! Description + ! Accumulate glc inputs + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eli + type(mct_avect), pointer :: l2x_lx + character(*), parameter :: subname = '(prep_glc_accum)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eli = 1,num_inst_lnd + l2x_lx => component_get_c2x_cx(lnd(eli)) + if (l2gacc_lx_cnt == 0) then + call mct_avect_copy(l2x_lx, l2gacc_lx(eli)) + else + call mct_avect_accum(l2x_lx, l2gacc_lx(eli)) + endif + end do + l2gacc_lx_cnt = l2gacc_lx_cnt + 1 + call t_drvstopf (trim(timer)) + + end subroutine prep_glc_accum + + !================================================================================================ + + subroutine prep_glc_accum_avg(timer) + + !--------------------------------------------------------------- + ! Description + ! Finalize accumulation of glc inputs + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eli + character(*), parameter :: subname = '(prep_glc_accum_avg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + if (l2gacc_lx_cnt > 1) then + do eli = 1,num_inst_lnd + call mct_avect_avg(l2gacc_lx(eli), l2gacc_lx_cnt) + end do + end if + l2gacc_lx_cnt = 0 + call t_drvstopf (trim(timer)) + + end subroutine prep_glc_accum_avg + + !================================================================================================ + + subroutine prep_glc_mrg(infodata, fractions_gx, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Merge glc inputs + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type(mct_aVect) , intent(in) :: fractions_gx(:) + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: egi, eli, efi + type(mct_avect), pointer :: x2g_gx + character(*), parameter :: subname = '(prep_glc_mrg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_mrg),barrier=mpicom_CPLID) + do egi = 1,num_inst_glc + ! Use fortran mod to address ensembles in merge + eli = mod((egi-1),num_inst_lnd) + 1 + efi = mod((egi-1),num_inst_frc) + 1 + + x2g_gx => component_get_x2c_cx(glc(egi)) + call prep_glc_merge(l2x_gx(eli), fractions_gx(efi), x2g_gx) + enddo + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_glc_mrg + + !================================================================================================ + + subroutine prep_glc_merge( l2x_g, fractions_g, x2g_g ) + + !----------------------------------------------------------------------- + ! Description + ! "Merge" land forcing for glc input. + ! + ! State fields are copied directly, meaning that averages are taken just over the + ! land-covered portion of the glc domain. + ! + ! Flux fields are downweighted by landfrac, which effectively sends a 0 flux from the + ! non-land-covered portion of the glc domain. + ! + ! Arguments + type(mct_aVect), intent(inout) :: l2x_g ! input + type(mct_aVect), intent(in) :: fractions_g + type(mct_aVect), intent(inout) :: x2g_g ! output + !----------------------------------------------------------------------- + + integer :: num_flux_fields + integer :: num_state_fields + integer :: nflds + integer :: i,n + integer :: mrgstr_index + integer :: index_l2x + integer :: index_x2g + integer :: index_lfrac + integer :: lsize + logical :: iamroot + real(r8) :: lfrac + logical, save :: first_time = .true. + character(CL),allocatable :: mrgstr(:) ! temporary string + character(CL) :: field ! string converted to char + character(*), parameter :: subname = '(prep_glc_merge) ' + + !----------------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + lsize = mct_aVect_lsize(x2g_g) + + num_flux_fields = shr_string_listGetNum(trim(seq_flds_x2g_fluxes)) + num_state_fields = shr_string_listGetNum(trim(seq_flds_x2g_states)) + + if (first_time) then + nflds = mct_aVect_nRattr(x2g_g) + if (nflds /= (num_flux_fields + num_state_fields)) then + write(logunit,*) subname,' ERROR: nflds /= num_flux_fields + num_state_fields: ', & + nflds, num_flux_fields, num_state_fields + call shr_sys_abort(subname//' ERROR: nflds /= num_flux_fields + num_state_fields') + end if + + allocate(mrgstr(nflds)) + end if + + mrgstr_index = 1 + + do i = 1, num_state_fields + call seq_flds_getField(field, i, seq_flds_x2g_states) + index_l2x = mct_aVect_indexRA(l2x_g, trim(field)) + index_x2g = mct_aVect_indexRA(x2g_g, trim(field)) + + if (first_time) then + mrgstr(mrgstr_index) = subname//'x2g%'//trim(field)//' =' // & + ' = l2x%'//trim(field) + end if + + do n = 1, lsize + x2g_g%rAttr(index_x2g,n) = l2x_g%rAttr(index_l2x,n) + end do + + mrgstr_index = mrgstr_index + 1 + enddo + + index_lfrac = mct_aVect_indexRA(fractions_g,"lfrac") + do i = 1, num_flux_fields + + call seq_flds_getField(field, i, seq_flds_x2g_fluxes) + index_l2x = mct_aVect_indexRA(l2x_g, trim(field)) + index_x2g = mct_aVect_indexRA(x2g_g, trim(field)) + + if (trim(field) == qice_fieldname) then + + if (first_time) then + mrgstr(mrgstr_index) = subname//'x2g%'//trim(field)//' =' // & + ' = l2x%'//trim(field) + end if + + ! treat qice as if it were a state variable, with a simple copy. + do n = 1, lsize + x2g_g%rAttr(index_x2g,n) = l2x_g%rAttr(index_l2x,n) + end do + + else + write(logunit,*) subname,' ERROR: Flux fields other than ', & + qice_fieldname, ' currently are not handled in lnd2glc remapping.' + write(logunit,*) '(Attempt to handle flux field <', trim(field), '>.)' + write(logunit,*) 'Substantial thought is needed to determine how to remap other fluxes' + write(logunit,*) 'in a smooth, conservative manner.' + call shr_sys_abort(subname//& + ' ERROR: Flux fields other than qice currently are not handled in lnd2glc remapping.') + endif ! qice_fieldname + + mrgstr_index = mrgstr_index + 1 + + end do + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do i = 1,nflds + write(logunit,'(A)') trim(mrgstr(i)) + enddo + endif + deallocate(mrgstr) + endif + + first_time = .false. + + end subroutine prep_glc_merge + + !================================================================================================ + + subroutine prep_glc_calc_l2x_gx(fractions_lx, timer) + !--------------------------------------------------------------- + ! Description + ! Create l2x_gx (note that l2x_gx is a local module variable) + ! Also l2x_gx is really the accumulated l2xacc_lx mapped to l2x_gx + ! + use shr_string_mod, only : shr_string_listGetNum + ! Arguments + type(mct_aVect) , intent(in) :: fractions_lx(:) + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: egi, eli, efi + integer :: num_flux_fields + integer :: num_state_fields + integer :: field_num + character(len=cl) :: fieldname + character(*), parameter :: subname = '(prep_glc_calc_l2x_gx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + + num_flux_fields = shr_string_listGetNum(trim(seq_flds_x2g_fluxes)) + num_state_fields = shr_string_listGetNum(trim(seq_flds_x2g_states)) + + do egi = 1,num_inst_glc + ! Use fortran mod to address ensembles in merge + eli = mod((egi-1),num_inst_lnd) + 1 + efi = mod((egi-1),num_inst_frc) + 1 + + do field_num = 1, num_flux_fields + call seq_flds_getField(fieldname, field_num, seq_flds_x2g_fluxes) + + if (trim(fieldname) == qice_fieldname) then + + ! Use a bilinear (Sl2g) mapper, as for states. + ! The Fg2l mapper is needed to map some glc fields to the land grid + ! for purposes of conservation. + call prep_glc_map_qice_conservative_lnd2glc(egi=egi, eli=eli, & + fractions_lx = fractions_lx(efi), & + mapper_Sl2g = mapper_Sl2g, & + mapper_Fg2l = mapper_Fg2l) + + else + write(logunit,*) subname,' ERROR: Flux fields other than ', & + qice_fieldname, ' currently are not handled in lnd2glc remapping.' + write(logunit,*) '(Attempt to handle flux field <', trim(fieldname), '>.)' + write(logunit,*) 'Substantial thought is needed to determine how to remap other fluxes' + write(logunit,*) 'in a smooth, conservative manner.' + call shr_sys_abort(subname//& + ' ERROR: Flux fields other than qice currently are not handled in lnd2glc remapping.') + endif ! qice_fieldname + + end do + + do field_num = 1, num_state_fields + call seq_flds_getField(fieldname, field_num, seq_flds_x2g_states) + call prep_glc_map_one_state_field_lnd2glc(egi=egi, eli=eli, & + fieldname = fieldname, & + fractions_lx = fractions_lx(efi), & + mapper = mapper_Sl2g) + end do + + enddo ! egi + + call t_drvstopf (trim(timer)) + + end subroutine prep_glc_calc_l2x_gx + + !================================================================================================ + + subroutine prep_glc_map_one_state_field_lnd2glc(egi, eli, fieldname, fractions_lx, mapper) + ! Maps a single field from the land grid to the glc grid. + ! + ! This mapping is not conservative, so should only be used for state fields. + ! + ! NOTE(wjs, 2017-05-10) We used to map each field separately because each field needed + ! its own vertical gradient calculator. Now that we don't need vertical gradient + ! calculators, we may be able to change this to map multiple fields at once, at least + ! for part of map_lnd2glc. + + use map_lnd2glc_mod, only : map_lnd2glc + + ! Arguments + integer, intent(in) :: egi ! glc instance index + integer, intent(in) :: eli ! lnd instance index + character(len=*), intent(in) :: fieldname ! base name of field to map (without elevation class suffix) + type(mct_aVect) , intent(in) :: fractions_lx ! fractions on the land grid, for this frac instance + type(seq_map), intent(inout) :: mapper + ! + ! Local Variables + type(mct_avect), pointer :: g2x_gx ! glc export, glc grid, cpl pes - allocated in driver + !--------------------------------------------------------------- + + g2x_gx => component_get_c2x_cx(glc(egi)) + + call map_lnd2glc(l2x_l = l2gacc_lx(eli), & + landfrac_l = fractions_lx, & + g2x_g = g2x_gx, & + fieldname = fieldname, & + mapper = mapper, & + l2x_g = l2x_gx(eli)) + + end subroutine prep_glc_map_one_state_field_lnd2glc + + !================================================================================================ + + subroutine prep_glc_zero_fields() + + !--------------------------------------------------------------- + ! Description + ! Set glc inputs to zero + ! + ! This is appropriate during time intervals when we're not sending valid data to glc. + ! In principle we shouldn't need to zero the fields at these times (instead, glc + ! should just ignore the fields at these times). However, some tests (like an ERS or + ! ERI test that stops the final run segment mid-year) can fail if we don't explicitly + ! zero the fields, because these x2g fields can then differ upon restart. + + ! Local Variables + integer :: egi + type(mct_avect), pointer :: x2g_gx + !--------------------------------------------------------------- + + do egi = 1,num_inst_glc + x2g_gx => component_get_x2c_cx(glc(egi)) + call mct_aVect_zero(x2g_gx) + end do + end subroutine prep_glc_zero_fields + + !================================================================================================ + + subroutine prep_glc_map_qice_conservative_lnd2glc(egi, eli, fractions_lx, & + mapper_Sl2g, mapper_Fg2l) + + ! Maps the surface mass balance field (qice) from the land grid to the glc grid. + ! + ! Use a smooth, non-conservative (bilinear) mapping, followed by a correction for + ! conservation. + ! + ! For high-level design, see: + ! https://docs.google.com/document/d/1H_SuK6SfCv1x6dK91q80dFInPbLYcOkUj_iAa6WRnqQ/edit + + use map_lnd2glc_mod, only : map_lnd2glc + + ! Arguments + integer, intent(in) :: egi ! glc instance index + integer, intent(in) :: eli ! lnd instance index + type(mct_aVect) , intent(in) :: fractions_lx ! fractions on the land grid, for this frac instance + type(seq_map), intent(inout) :: mapper_Sl2g ! state mapper from land to glc grid; non-conservative + type(seq_map), intent(inout) :: mapper_Fg2l ! flux mapper from glc to land grid; conservative + ! + ! Local Variables + type(mct_aVect), pointer :: g2x_gx ! glc export, glc grid + + logical :: iamroot + + !Note: The sums in this subroutine use the coupler areas aream_l and aream_g. + ! The coupler areas can differ from the native areas area_l and area_g. + ! (For CISM with a polar stereographic projection, area_g can differ from aream_g + ! by up to ~10%.) + ! If so, then the calls to subroutine mct_avect_vecmult in component_mod.F90 + ! (just before and after the call to comp_run) should adjust the SMB fluxes + ! such that in each grid cell, the native value of area*flux is equal to the + ! coupler value of aream*flux. This assumes that the SMB field is contained in + ! seq_fields l2x_fluxes and seq_fields_x2g_fluxes. + + real(r8), dimension(:), allocatable :: aream_g ! cell areas on glc grid, for mapping + real(r8), dimension(:), allocatable :: area_g ! cell areas on glc grid, according to glc model + + type(mct_ggrid), pointer :: dom_g ! glc grid info + + integer :: lsize_g ! number of points on glc grid + + integer :: n + integer :: km, ka + + real(r8), pointer :: qice_g(:) ! qice data on glc grid + + !--------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + + if (iamroot) then + write(logunit,*) ' ' + write(logunit,*) 'In prep_glc_map_qice_conservative_lnd2glc' + write(logunit,*) 'smb_renormalize = ', smb_renormalize + endif + + ! Get attribute vector needed for mapping and conservation + g2x_gx => component_get_c2x_cx(glc(egi)) + + ! get grid size + lsize_g = mct_aVect_lsize(l2x_gx(eli)) + + ! allocate and fill area arrays on the glc grid + ! (Note that we get domain information from instance 1, following what's done in + ! other parts of the coupler.) + dom_g => component_get_dom_cx(glc(1)) + + allocate(aream_g(lsize_g)) + km = mct_aVect_indexRa(dom_g%data, "aream" ) + aream_g(:) = dom_g%data%rAttr(km,:) + + allocate(area_g(lsize_g)) + ka = mct_aVect_indexRa(dom_g%data, "area" ) + area_g(:) = dom_g%data%rAttr(ka,:) + + ! Map the SMB from the land grid to the glc grid, using a non-conservative state mapper. + call map_lnd2glc(l2x_l = l2gacc_lx(eli), & + landfrac_l = fractions_lx, & + g2x_g = g2x_gx, & + fieldname = qice_fieldname, & + mapper = mapper_Sl2g, & + l2x_g = l2x_gx(eli)) + + ! Export the remapped SMB to a local array + allocate(qice_g(lsize_g)) + call mct_aVect_exportRattr(l2x_gx(eli), trim(qice_fieldname), qice_g) + + ! Make a preemptive adjustment to qice_g to account for area differences between CISM and the coupler. + ! In component_mod.F90, there is a call to mct_avect_vecmult, which multiplies the fluxes + ! by aream_g/area_g for conservation purposes. Where CISM areas are larger (area_g > aream_g), + ! the fluxes are reduced, and where CISM areas are smaller, the fluxes are increased. + ! As a result, an SMB of 1 m/yr in CLM would be converted to an SMB ranging from + ! ~0.9 to 1.05 m/yr in CISM (with smaller values where CISM areas are larger, and larger + ! values where CISM areas are smaller). + ! Here, to keep CISM values close to the CLM values in the corresponding locations, + ! we anticipate the later correction and multiply qice_g by area_g/aream_g. + ! Then the later call to mct_avect_vecmult will bring qice back to the original values + ! obtained from bilinear remapping. + ! If Flgl_qice were changed to a state (and not included in seq_flds_x2g_fluxes), + ! then we could skip this adjustment. + ! + ! Note that we are free to do this or any other adjustments we want to qice at this + ! point in the remapping, because the conservation correction will ensure that we + ! still conserve globally despite these adjustments (and smb_renormalize = .false. + ! should only be used in cases where conservation doesn't matter anyway). + + do n = 1, lsize_g + if (aream_g(n) > 0.0_r8) then + qice_g(n) = qice_g(n) * area_g(n)/aream_g(n) + else + qice_g(n) = 0.0_r8 + endif + enddo + + if (smb_renormalize) then + call prep_glc_renormalize_smb( & + eli = eli, & + fractions_lx = fractions_lx, & + g2x_gx = g2x_gx, & + mapper_Fg2l = mapper_Fg2l, & + aream_g = aream_g, & + qice_g = qice_g) + end if + + ! Put the adjusted SMB back into l2x_gx. + ! + ! If we are doing renormalization, then this is the renormalized SMB. Whether or not + ! we are doing renormalization, this captures the preemptive adjustment to qice_g to + ! account for area differences between CISM and the coupler. + call mct_aVect_importRattr(l2x_gx(eli), qice_fieldname, qice_g) + + ! clean up + + deallocate(aream_g) + deallocate(area_g) + deallocate(qice_g) + + end subroutine prep_glc_map_qice_conservative_lnd2glc + + !================================================================================================ + + subroutine prep_glc_renormalize_smb(eli, fractions_lx, g2x_gx, mapper_Fg2l, aream_g, qice_g) + + ! Renormalizes surface mass balance (smb, here named qice_g) so that the global + ! integral on the glc grid is equal to the global integral on the land grid. + ! + ! This is required for conservation - although conservation is only necessary if we + ! are running with a fully-interactive, two-way-coupled glc. + ! + ! For high-level design, see: + ! https://docs.google.com/document/d/1H_SuK6SfCv1x6dK91q80dFInPbLYcOkUj_iAa6WRnqQ/edit + + use map_glc2lnd_mod, only : map_glc2lnd_ec + + ! Arguments + integer , intent(in) :: eli ! lnd instance index + type(mct_aVect) , intent(in) :: fractions_lx ! fractions on the land grid, for this frac instance + type(mct_aVect) , intent(in) :: g2x_gx ! glc export, glc grid + type(seq_map) , intent(inout) :: mapper_Fg2l ! flux mapper from glc to land grid; conservative + real(r8) , intent(in) :: aream_g(:) ! cell areas on glc grid, for mapping + real(r8) , intent(inout) :: qice_g(:) ! qice data on glc grid + + ! + ! Local Variables + integer :: mpicom + logical :: iamroot + + type(mct_ggrid), pointer :: dom_l ! land grid info + + integer :: lsize_l ! number of points on land grid + integer :: lsize_g ! number of points on glc grid + + real(r8), dimension(:), allocatable :: aream_l ! cell areas on land grid, for mapping + + real(r8), pointer :: qice_l(:,:) ! SMB (Flgl_qice) on land grid + real(r8), pointer :: frac_l(:,:) ! EC fractions (Sg_ice_covered) on land grid + real(r8), pointer :: tmp_field_l(:) ! temporary field on land grid + + ! The following need to be pointers to satisfy the MCT interface + ! Note: Sg_icemask defines where the ice sheet model can receive a nonzero SMB from the land model. + real(r8), pointer :: Sg_icemask_g(:) ! icemask on glc grid + real(r8), pointer :: Sg_icemask_l(:) ! icemask on land grid + real(r8), pointer :: lfrac(:) ! land fraction on land grid + + type(mct_aVect) :: g2x_lx ! glc export, lnd grid (not a pointer: created locally) + type(mct_avect) :: Sg_icemask_l_av ! temporary attribute vector holding Sg_icemask on the land grid + + integer :: nEC ! number of elevation classes + integer :: n + integer :: ec + integer :: km + + ! various strings for building field names + character(len=:), allocatable :: elevclass_as_string + character(len=:), allocatable :: qice_field + character(len=:), allocatable :: frac_field + + ! local and global sums of accumulation and ablation; used to compute renormalization factors + + real(r8) :: local_accum_on_land_grid + real(r8) :: global_accum_on_land_grid + real(r8) :: local_accum_on_glc_grid + real(r8) :: global_accum_on_glc_grid + + real(r8) :: local_ablat_on_land_grid + real(r8) :: global_ablat_on_land_grid + real(r8) :: local_ablat_on_glc_grid + real(r8) :: global_ablat_on_glc_grid + + ! renormalization factors (should be close to 1, e.g. in range 0.95 to 1.05) + real(r8) :: accum_renorm_factor ! ratio between global accumulation on the two grids + real(r8) :: ablat_renorm_factor ! ratio between global ablation on the two grids + + real(r8) :: effective_area ! grid cell area multiplied by min(lfrac,Sg_icemask_l). + ! This is the area that can contribute SMB to the ice sheet model. + + + !--------------------------------------------------------------- + + lsize_g = size(qice_g) + SHR_ASSERT_FL((size(aream_g) == lsize_g), __FILE__, __LINE__) + + call seq_comm_setptrs(CPLID, mpicom=mpicom) + call seq_comm_getdata(CPLID, iamroot=iamroot) + lsize_l = mct_aVect_lsize(l2gacc_lx(eli)) + + ! allocate and fill area arrays on the land grid + ! (Note that we get domain information from instance 1, following what's done in + ! other parts of the coupler.) + dom_l => component_get_dom_cx(lnd(1)) + + allocate(aream_l(lsize_l)) + km = mct_aVect_indexRa(dom_l%data, "aream" ) + aream_l(:) = dom_l%data%rAttr(km,:) + + ! Export land fractions from fractions_lx to a local array + allocate(lfrac(lsize_l)) + call mct_aVect_exportRattr(fractions_lx, "lfrac", lfrac) + + ! Map Sg_icemask from the glc grid to the land grid. + ! This may not be necessary, if Sg_icemask_l has already been mapped from Sg_icemask_g. + ! It is done here for two reasons: + ! (1) The mapping will *not* have been done if we are running with dlnd (e.g., a TG case). + ! (2) Because of coupler lags, the current Sg_icemask_l might not be up to date with + ! Sg_icemask_g. This probably isn't a problem in practice, but doing the mapping + ! here ensures the mask is up to date. + ! + ! This mapping uses the same options as the standard glc -> lnd mapping done in + ! prep_lnd_calc_g2x_lx. If that mapping ever changed (e.g., changing norm to + ! .false.), then we should change this mapping, too. + ! + ! BUG(wjs, 2017-05-11, #1516) I think we actually want norm = .false. here, but this + ! requires some more thought + call mct_aVect_init(Sg_icemask_l_av, rList = Sg_icemask_field, lsize = lsize_l) + call seq_map_map(mapper = mapper_Fg2l, & + av_s = g2x_gx, & + av_d = Sg_icemask_l_av, & + fldlist = Sg_icemask_field, & + norm = .true.) + + ! Export Sg_icemask_l from the temporary attribute vector to a local array + allocate(Sg_icemask_l(lsize_l)) + call mct_aVect_exportRattr(Sg_icemask_l_av, Sg_icemask_field, Sg_icemask_l) + + ! Clean the temporary attribute vector + call mct_aVect_clean(Sg_icemask_l_av) + + ! Map Sg_ice_covered from the glc grid to the land grid. + ! This gives the fields Sg_ice_covered00, Sg_ice_covered01, etc. on the land grid. + ! These fields are needed to integrate the total SMB on the land grid, for conservation purposes. + ! As above, the mapping may not be necessary, because Sg_ice_covered might already have been mapped. + ! However, the mapping will not have been done in a TG case with dlnd, and it might not + ! be up to date because of coupler lags (though the latter probably isn't a problem + ! in practice). + ! + ! Note that, for a case with full two-way coupling, we will only conserve if the + ! actual land cover used over the course of the year matches these currently-remapped + ! values. This should generally be the case with the current coupling setup. + ! + ! One could argue that it would be safer (for conservation purposes) if LND sent its + ! grid cell average SMB values, or if it sent its own notion of the area in each + ! elevation class for the purpose of creating grid cell average SMB values here. But + ! these options cause problems if we're not doing full two-way coupling (e.g., in a TG + ! case with dlnd, or in the common case where GLC is a diagnostic component that + ! doesn't cause updates in the glacier areas in LND). In these cases without full + ! two-way coupling, if we use the LND's notion of the area in each elevation class, + ! then the conservation corrections would end up correcting for discrepancies in + ! elevation class areas between LND and GLC, rather than just correcting for + ! discrepancies arising from the remapping of SMB. (And before you get worried: It + ! doesn't matter that we are not conserving in these cases without full two-way + ! coupling, because GLC isn't connected with the rest of the system in terms of energy + ! and mass in these cases. So in these cases, it's okay that the LND integral computed + ! here differs from the integral that LND itself would compute.) + + ! Create an attribute vector g2x_lx to hold the mapped fields + call mct_aVect_init(g2x_lx, rList=g2x_lx_fields, lsize=lsize_l) + + ! Map Sg_ice_covered and Sg_topo from glc to land + call map_glc2lnd_ec( & + g2x_g = g2x_gx, & + frac_field = Sg_frac_field, & + topo_field = Sg_topo_field, & + icemask_field = Sg_icemask_field, & + extra_fields = ' ', & ! no extra fields + mapper = mapper_Fg2l, & + g2x_l = g2x_lx) + + ! Export qice and Sg_ice_covered in each elevation class to local arrays. + ! Note: qice comes from l2gacc_lx; frac comes from g2x_lx. + + nEC = glc_get_num_elevation_classes() + + allocate(qice_l(lsize_l,0:nEC)) + allocate(frac_l(lsize_l,0:nEC)) + allocate(tmp_field_l(lsize_l)) + + do ec = 0, nEC + elevclass_as_string = glc_elevclass_as_string(ec) + + frac_field = Sg_frac_field // elevclass_as_string ! Sg_ice_covered01, etc. + call mct_aVect_exportRattr(g2x_lx, trim(frac_field), tmp_field_l) + frac_l(:,ec) = tmp_field_l(:) + + qice_field = qice_fieldname // elevclass_as_string ! Flgl_qice01, etc. + call mct_aVect_exportRattr(l2gacc_lx(eli), trim(qice_field), tmp_field_l) + qice_l(:,ec) = tmp_field_l(:) + + enddo + + ! clean the temporary attribute vector g2x_lx + call mct_aVect_clean(g2x_lx) + + ! Sum qice over local land grid cells + + ! initialize qice sum + local_accum_on_land_grid = 0.0_r8 + local_ablat_on_land_grid = 0.0_r8 + + do n = 1, lsize_l + + effective_area = min(lfrac(n),Sg_icemask_l(n)) * aream_l(n) + + do ec = 0, nEC + + if (qice_l(n,ec) >= 0.0_r8) then + local_accum_on_land_grid = local_accum_on_land_grid & + + effective_area * frac_l(n,ec) * qice_l(n,ec) + else + local_ablat_on_land_grid = local_ablat_on_land_grid & + + effective_area * frac_l(n,ec) * qice_l(n,ec) + endif + + enddo ! ec + + enddo ! n + + call shr_mpi_sum(local_accum_on_land_grid, & + global_accum_on_land_grid, & + mpicom, 'accum_l') + + call shr_mpi_sum(local_ablat_on_land_grid, & + global_ablat_on_land_grid, & + mpicom, 'ablat_l') + + call shr_mpi_bcast(global_accum_on_land_grid, mpicom) + call shr_mpi_bcast(global_ablat_on_land_grid, mpicom) + + ! Sum qice_g over local glc grid cells. + ! Note: This sum uses the coupler areas (aream_g), which differ from the native CISM areas. + ! But since the original qice_g (from bilinear remapping) has been multiplied by + ! area_g/aream_g above, this calculation is equivalent to multiplying the original qice_g + ! by the native CISM areas (area_g). + ! If Flgl_qice were changed to a state (and not included in seq_flds_x2g_fluxes), + ! then it would be appropriate to use the native CISM areas in this sum. + + ! Export Sg_icemask from g2x_gx to a local array + allocate(Sg_icemask_g(lsize_g)) + call mct_aVect_exportRattr(g2x_gx, Sg_icemask_field, Sg_icemask_g) + + local_accum_on_glc_grid = 0.0_r8 + local_ablat_on_glc_grid = 0.0_r8 + + do n = 1, lsize_g + + if (qice_g(n) >= 0.0_r8) then + local_accum_on_glc_grid = local_accum_on_glc_grid & + + Sg_icemask_g(n) * aream_g(n) * qice_g(n) + else + local_ablat_on_glc_grid = local_ablat_on_glc_grid & + + Sg_icemask_g(n) * aream_g(n) * qice_g(n) + endif + + enddo ! n + + call shr_mpi_sum(local_accum_on_glc_grid, & + global_accum_on_glc_grid, & + mpicom, 'accum_g') + + call shr_mpi_sum(local_ablat_on_glc_grid, & + global_ablat_on_glc_grid, & + mpicom, 'ablat_g') + + call shr_mpi_bcast(global_accum_on_glc_grid, mpicom) + call shr_mpi_bcast(global_ablat_on_glc_grid, mpicom) + + ! Renormalize + + if (global_accum_on_glc_grid > 0.0_r8) then + accum_renorm_factor = global_accum_on_land_grid / global_accum_on_glc_grid + else + accum_renorm_factor = 0.0_r8 + endif + + if (global_ablat_on_glc_grid < 0.0_r8) then ! negative by definition + ablat_renorm_factor = global_ablat_on_land_grid / global_ablat_on_glc_grid + else + ablat_renorm_factor = 0.0_r8 + endif + + if (iamroot) then + write(logunit,*) 'accum_renorm_factor = ', accum_renorm_factor + write(logunit,*) 'ablat_renorm_factor = ', ablat_renorm_factor + endif + + do n = 1, lsize_g + if (qice_g(n) >= 0.0_r8) then + qice_g(n) = qice_g(n) * accum_renorm_factor + else + qice_g(n) = qice_g(n) * ablat_renorm_factor + endif + enddo + + deallocate(aream_l) + deallocate(lfrac) + deallocate(Sg_icemask_l) + deallocate(Sg_icemask_g) + deallocate(tmp_field_l) + deallocate(qice_l) + deallocate(frac_l) + + end subroutine prep_glc_renormalize_smb + + !================================================================================================ + + function prep_glc_get_l2x_gx() + type(mct_aVect), pointer :: prep_glc_get_l2x_gx(:) + prep_glc_get_l2x_gx => l2x_gx(:) + end function prep_glc_get_l2x_gx + + function prep_glc_get_l2gacc_lx() + type(mct_aVect), pointer :: prep_glc_get_l2gacc_lx(:) + prep_glc_get_l2gacc_lx => l2gacc_lx(:) + end function prep_glc_get_l2gacc_lx + + function prep_glc_get_l2gacc_lx_cnt() + integer, pointer :: prep_glc_get_l2gacc_lx_cnt + prep_glc_get_l2gacc_lx_cnt => l2gacc_lx_cnt + end function prep_glc_get_l2gacc_lx_cnt + + function prep_glc_get_mapper_Sl2g() + type(seq_map), pointer :: prep_glc_get_mapper_Sl2g + prep_glc_get_mapper_Sl2g => mapper_Sl2g + end function prep_glc_get_mapper_Sl2g + + function prep_glc_get_mapper_Fl2g() + type(seq_map), pointer :: prep_glc_get_mapper_Fl2g + prep_glc_get_mapper_Fl2g => mapper_Fl2g + end function prep_glc_get_mapper_Fl2g + +end module prep_glc_mod diff --git a/driver-mct/main/prep_ice_mod.F90 b/driver-mct/main/prep_ice_mod.F90 new file mode 100644 index 000000000000..4b44e698f8bc --- /dev/null +++ b/driver-mct/main/prep_ice_mod.F90 @@ -0,0 +1,575 @@ +module prep_ice_mod + + use shr_kind_mod , only: r8 => SHR_KIND_R8 + use shr_kind_mod , only: cs => SHR_KIND_CS + use shr_kind_mod , only: cl => SHR_KIND_CL + use shr_sys_mod , only: shr_sys_abort, shr_sys_flush + use seq_comm_mct , only: num_inst_atm, num_inst_ocn, num_inst_glc + use seq_comm_mct , only: num_inst_ice, num_inst_frc, num_inst_rof + use seq_comm_mct , only: CPLID, ICEID, logunit + use seq_comm_mct , only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: ice, atm, ocn, glc, rof + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_ice_init + public :: prep_ice_mrg + + public :: prep_ice_calc_a2x_ix + public :: prep_ice_calc_o2x_ix + public :: prep_ice_calc_r2x_ix + public :: prep_ice_calc_g2x_ix + + public :: prep_ice_get_a2x_ix + public :: prep_ice_get_o2x_ix + public :: prep_ice_get_g2x_ix + public :: prep_ice_get_r2x_ix + + public :: prep_ice_get_mapper_SFo2i + public :: prep_ice_get_mapper_Rg2i + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_ice_merge + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_SFo2i + type(seq_map), pointer :: mapper_Rg2i + type(seq_map), pointer :: mapper_Rr2i + + ! attribute vectors + type(mct_aVect), pointer :: a2x_ix(:) ! Atm export, ice grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: o2x_ix(:) ! Ocn export, ice grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: g2x_ix(:) ! Glc export, ice grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: r2x_ix(:) ! Rof export, ice grid, cpl pes - allocated in driver + + ! seq_comm_getData variables + integer :: mpicom_CPLID ! MPI cpl communicator + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_ice_init(infodata, ocn_c2_ice, glc_c2_ice, rof_c2_ice) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and all other non-mapping + ! module variables + ! + ! Arguments + type (seq_infodata_type) , intent(in) :: infodata + logical, intent(in) :: ocn_c2_ice ! .true. => ocn to ice coupling on + logical, intent(in) :: glc_c2_ice ! .true. => glc to ice coupling on + logical, intent(in) :: rof_c2_ice ! .true. => rof to ice coupling on + ! + ! Local Variables + integer :: lsize_i + integer :: eai, eoi, egi, eri, eii + logical :: iamroot_CPLID ! .true. => CPLID masterproc + logical :: samegrid_ig ! samegrid glc and ice + logical :: samegrid_ro ! samegrid rof and ice/ocn + logical :: ice_present ! .true. => ice is present + logical :: esmf_map_flag ! .true. => use esmf for mapping + character(CL) :: ice_gnam ! ice grid + character(CL) :: ocn_gnam ! ocn grid + character(CL) :: glc_gnam ! glc grid + character(CL) :: rof_gnam ! rof grid + type(mct_avect), pointer :: i2x_ix + character(*), parameter :: subname = '(prep_ice_init)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + esmf_map_flag=esmf_map_flag , & + ice_present=ice_present , & + ice_gnam=ice_gnam , & + ocn_gnam=ocn_gnam , & + rof_gnam=rof_gnam , & + glc_gnam=glc_gnam) + + allocate(mapper_SFo2i) + allocate(mapper_Rg2i) + allocate(mapper_Rr2i) + + if (ice_present) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + i2x_ix => component_get_c2x_cx(ice(1)) + lsize_i = mct_aVect_lsize(i2x_ix) + + allocate(a2x_ix(num_inst_atm)) + do eai = 1,num_inst_atm + call mct_aVect_init(a2x_ix(eai), rList=seq_flds_a2x_fields, lsize=lsize_i) + call mct_aVect_zero(a2x_ix(eai)) + end do + allocate(o2x_ix(num_inst_ocn)) + do eoi = 1,num_inst_ocn + call mct_aVect_init(o2x_ix(eoi), rList=seq_flds_o2x_fields, lsize=lsize_i) + call mct_aVect_zero(o2x_ix(eoi)) + enddo + allocate(g2x_ix(num_inst_glc)) + do egi = 1,num_inst_glc + call mct_aVect_init(g2x_ix(egi), rList=seq_flds_g2x_fields, lsize=lsize_i) + call mct_aVect_zero(g2x_ix(egi)) + enddo + allocate(r2x_ix(num_inst_rof)) + do eri = 1,num_inst_rof + call mct_aVect_init(r2x_ix(eri), rList=seq_flds_r2x_fields, lsize=lsize_i) + call mct_aVect_zero(r2x_ix(eri)) + end do + + samegrid_ig = .true. + samegrid_ro = .true. + if (trim(ice_gnam) /= trim(glc_gnam)) samegrid_ig = .false. + if (trim(rof_gnam) /= trim(ocn_gnam)) samegrid_ro = .false. + + if (ocn_c2_ice) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_SFo2i' + end if + call seq_map_init_rearrolap(mapper_SFo2i, ocn(1), ice(1), 'mapper_SFo2i') + endif + + if (glc_c2_ice) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Rg2i' + end if + call seq_map_init_rcfile(mapper_Rg2i, glc(1), ice(1), & + 'seq_maps.rc','glc2ice_rmapname:','glc2ice_rmaptype:',samegrid_ig, & + 'mapper_Rg2i initialization', esmf_map_flag) + endif + + if (rof_c2_ice) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Rr2i' + end if + call seq_map_init_rcfile(mapper_Rr2i, rof(1), ice(1), & + 'seq_maps.rc','rof2ice_rmapname:','rof2ice_rmaptype:',samegrid_ro, & + 'mapper_Rr2i initialization', esmf_map_flag) + endif + call shr_sys_flush(logunit) + + end if + + end subroutine prep_ice_init + + !================================================================================================ + + subroutine prep_ice_mrg(infodata, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Prepare run phase, including running the merge + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eoi, eai, egi, efi, eii, eri + real(r8) :: flux_epbalfact ! adjusted precip factor + type(mct_avect), pointer :: x2i_ix + character(*), parameter :: subname = '(prep_ice_mrg)' + !--------------------------------------------------------------- + + call seq_infodata_GetData(infodata, & + flux_epbalfact=flux_epbalfact) + + call t_drvstartf (trim(timer_mrg),barrier=mpicom_CPLID) + do eii = 1,num_inst_ice + ! Use fortran mod to address ensembles in merge + eai = mod((eii-1),num_inst_atm) + 1 + eoi = mod((eii-1),num_inst_ocn) + 1 + eri = mod((eii-1),num_inst_rof) + 1 + egi = mod((eii-1),num_inst_glc) + 1 + + ! Apply correction to precipitation of requested driver namelist + x2i_ix => component_get_x2c_cx(ice(eii)) ! This is actually modifying x2i_ix + call prep_ice_merge(flux_epbalfact, a2x_ix(eai), o2x_ix(eoi), r2x_ix(eri), g2x_ix(egi), & + x2i_ix) + enddo + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_ice_mrg + + !================================================================================================ + + subroutine prep_ice_merge(flux_epbalfact, a2x_i, o2x_i, r2x_i, g2x_i, x2i_i ) + + !----------------------------------------------------------------------- + ! + ! Arguments + real(r8) , intent(inout) :: flux_epbalfact + type(mct_aVect) , intent(in) :: a2x_i + type(mct_aVect) , intent(in) :: o2x_i + type(mct_aVect) , intent(in) :: r2x_i + type(mct_aVect) , intent(in) :: g2x_i + type(mct_aVect) , intent(inout) :: x2i_i + ! + ! Local variables + integer :: i,i1,o1,lsize + integer :: niflds + integer, save :: index_a2x_Faxa_rainc + integer, save :: index_a2x_Faxa_rainl + integer, save :: index_a2x_Faxa_snowc + integer, save :: index_a2x_Faxa_snowl + integer, save :: index_g2x_Figg_rofi + integer, save :: index_r2x_Firr_rofi + integer, save :: index_x2i_Faxa_rain + integer, save :: index_x2i_Faxa_snow + integer, save :: index_x2i_Fixx_rofi + !wiso fields: + integer, save :: index_a2x_Faxa_rainc_16O + integer, save :: index_a2x_Faxa_rainl_16O + integer, save :: index_a2x_Faxa_snowc_16O + integer, save :: index_a2x_Faxa_snowl_16O + integer, save :: index_x2i_Faxa_rain_16O + integer, save :: index_x2i_Faxa_snow_16O + integer, save :: index_a2x_Faxa_rainc_18O + integer, save :: index_a2x_Faxa_rainl_18O + integer, save :: index_a2x_Faxa_snowc_18O + integer, save :: index_a2x_Faxa_snowl_18O + integer, save :: index_x2i_Faxa_rain_18O + integer, save :: index_x2i_Faxa_snow_18O + integer, save :: index_a2x_Faxa_rainc_HDO + integer, save :: index_a2x_Faxa_rainl_HDO + integer, save :: index_a2x_Faxa_snowc_HDO + integer, save :: index_a2x_Faxa_snowl_HDO + integer, save :: index_x2i_Faxa_rain_HDO + integer, save :: index_x2i_Faxa_snow_HDO + logical, save :: first_time = .true. + logical :: iamroot + character(CL),allocatable :: mrgstr(:) ! temporary string + character(CL) :: field ! string converted to char + type(mct_aVect_sharedindices),save :: o2x_sharedindices + type(mct_aVect_sharedindices),save :: a2x_sharedindices + type(mct_aVect_sharedindices),save :: g2x_sharedindices + character(*), parameter :: subname = '(prep_ice_merge) ' + !----------------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + lsize = mct_aVect_lsize(x2i_i) + + if (first_time) then + niflds = mct_aVect_nRattr(x2i_i) + + allocate(mrgstr(niflds)) + index_a2x_Faxa_snowc = mct_aVect_indexRA(a2x_i,'Faxa_snowc') + index_a2x_Faxa_snowl = mct_aVect_indexRA(a2x_i,'Faxa_snowl') + index_a2x_Faxa_rainc = mct_aVect_indexRA(a2x_i,'Faxa_rainc') + index_a2x_Faxa_rainl = mct_aVect_indexRA(a2x_i,'Faxa_rainl') + index_g2x_Figg_rofi = mct_aVect_indexRA(g2x_i,'Figg_rofi') + index_r2x_Firr_rofi = mct_aVect_indexRA(r2x_i,'Firr_rofi') + index_x2i_Faxa_rain = mct_aVect_indexRA(x2i_i,'Faxa_rain' ) + index_x2i_Faxa_snow = mct_aVect_indexRA(x2i_i,'Faxa_snow' ) + index_x2i_Fixx_rofi = mct_aVect_indexRA(x2i_i,'Fixx_rofi') + + ! Water isotope fields + index_a2x_Faxa_snowc_16O = mct_aVect_indexRA(a2x_i,'Faxa_snowc_16O', perrWith='quiet') + index_a2x_Faxa_snowl_16O = mct_aVect_indexRA(a2x_i,'Faxa_snowl_16O', perrWith='quiet') + index_a2x_Faxa_rainc_16O = mct_aVect_indexRA(a2x_i,'Faxa_rainc_16O', perrWith='quiet') + index_a2x_Faxa_rainl_16O = mct_aVect_indexRA(a2x_i,'Faxa_rainl_16O', perrWith='quiet') + index_x2i_Faxa_rain_16O = mct_aVect_indexRA(x2i_i,'Faxa_rain_16O', perrWith='quiet' ) + index_x2i_Faxa_snow_16O = mct_aVect_indexRA(x2i_i,'Faxa_snow_16O', perrWith='quiet' ) + + index_a2x_Faxa_snowc_18O = mct_aVect_indexRA(a2x_i,'Faxa_snowc_18O', perrWith='quiet') + index_a2x_Faxa_snowl_18O = mct_aVect_indexRA(a2x_i,'Faxa_snowl_18O', perrWith='quiet') + index_a2x_Faxa_rainc_18O = mct_aVect_indexRA(a2x_i,'Faxa_rainc_18O', perrWith='quiet') + index_a2x_Faxa_rainl_18O = mct_aVect_indexRA(a2x_i,'Faxa_rainl_18O', perrWith='quiet') + index_x2i_Faxa_rain_18O = mct_aVect_indexRA(x2i_i,'Faxa_rain_18O', perrWith='quiet' ) + index_x2i_Faxa_snow_18O = mct_aVect_indexRA(x2i_i,'Faxa_snow_18O', perrWith='quiet' ) + + index_a2x_Faxa_snowc_HDO = mct_aVect_indexRA(a2x_i,'Faxa_snowc_HDO', perrWith='quiet') + index_a2x_Faxa_snowl_HDO = mct_aVect_indexRA(a2x_i,'Faxa_snowl_HDO', perrWith='quiet') + index_a2x_Faxa_rainc_HDO = mct_aVect_indexRA(a2x_i,'Faxa_rainc_HDO', perrWith='quiet') + index_a2x_Faxa_rainl_HDO = mct_aVect_indexRA(a2x_i,'Faxa_rainl_HDO', perrWith='quiet') + index_x2i_Faxa_rain_HDO = mct_aVect_indexRA(x2i_i,'Faxa_rain_HDO', perrWith='quiet' ) + index_x2i_Faxa_snow_HDO = mct_aVect_indexRA(x2i_i,'Faxa_snow_HDO', perrWith='quiet' ) + + do i = 1,niflds + field = mct_aVect_getRList2c(i, x2i_i) + mrgstr(i) = subname//'x2i%'//trim(field)//' =' + enddo + + call mct_aVect_setSharedIndices(o2x_i, x2i_i, o2x_SharedIndices) + call mct_aVect_setSharedIndices(a2x_i, x2i_i, a2x_SharedIndices) + call mct_aVect_setSharedIndices(g2x_i, x2i_i, g2x_SharedIndices) + + !--- document copy operations --- + do i=1,o2x_SharedIndices%shared_real%num_indices + i1=o2x_SharedIndices%shared_real%aVindices1(i) + o1=o2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, o2x_i) + mrgstr(o1) = trim(mrgstr(o1))//' = o2x%'//trim(field) + enddo + do i=1,a2x_SharedIndices%shared_real%num_indices + i1=a2x_SharedIndices%shared_real%aVindices1(i) + o1=a2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, a2x_i) + mrgstr(o1) = trim(mrgstr(o1))//' = a2x%'//trim(field) + enddo + do i=1,g2x_SharedIndices%shared_real%num_indices + i1=g2x_SharedIndices%shared_real%aVindices1(i) + o1=g2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, g2x_i) + mrgstr(o1) = trim(mrgstr(o1))//' = g2x%'//trim(field) + enddo + + !--- document manual merges --- + mrgstr(index_x2i_Faxa_rain) = trim(mrgstr(index_x2i_Faxa_rain))//' = '// & + '(a2x%Faxa_rainc + a2x%Faxa_rainl)*flux_epbalfact' + mrgstr(index_x2i_Faxa_snow) = trim(mrgstr(index_x2i_Faxa_snow))//' = '// & + '(a2x%Faxa_snowc + a2x%Faxa_snowl)*flux_epbalfact' + mrgstr(index_x2i_Fixx_rofi) = trim(mrgstr(index_x2i_Fixx_rofi))//' = '// & + '(g2x%Figg_rofi + r2x%Firr_rofi)*flux_epbalfact' + + !--- water isotope document manual merges --- + if ( index_x2i_Faxa_rain_16O /= 0 ) then + mrgstr(index_x2i_Faxa_rain_16O) = trim(mrgstr(index_x2i_Faxa_rain_16O))//' = '// & + '(a2x%Faxa_rainc_16O + a2x%Faxa_rainl_16O)*flux_epbalfact' + mrgstr(index_x2i_Faxa_snow_16O) = trim(mrgstr(index_x2i_Faxa_snow_16O))//' = '// & + '(a2x%Faxa_snowc_16O + a2x%Faxa_snowl_16O)*flux_epbalfact' + end if + if ( index_x2i_Faxa_rain_18O /= 0 ) then + mrgstr(index_x2i_Faxa_rain_18O) = trim(mrgstr(index_x2i_Faxa_rain_18O))//' = '// & + '(a2x%Faxa_rainc_18O + a2x%Faxa_rainl_18O)*flux_epbalfact' + mrgstr(index_x2i_Faxa_snow_18O) = trim(mrgstr(index_x2i_Faxa_snow_18O))//' = '// & + '(a2x%Faxa_snowc_18O + a2x%Faxa_snowl_18O)*flux_epbalfact' + end if + if ( index_x2i_Faxa_rain_HDO /= 0 ) then + mrgstr(index_x2i_Faxa_rain_HDO) = trim(mrgstr(index_x2i_Faxa_rain_HDO))//' = '// & + '(a2x%Faxa_rainc_HDO + a2x%Faxa_rainl_HDO)*flux_epbalfact' + mrgstr(index_x2i_Faxa_snow_HDO) = trim(mrgstr(index_x2i_Faxa_snow_HDO))//' = '// & + '(a2x%Faxa_snowc_HDO + a2x%Faxa_snowl_HDO)*flux_epbalfact' + end if + + endif + +! call mct_aVect_copy(aVin=o2x_i, aVout=x2i_i, vector=mct_usevector) +! call mct_aVect_copy(aVin=a2x_i, aVout=x2i_i, vector=mct_usevector) +! call mct_aVect_copy(aVin=g2x_i, aVout=x2i_i, vector=mct_usevector) + call mct_aVect_copy(aVin=o2x_i, aVout=x2i_i, vector=mct_usevector, sharedIndices=o2x_SharedIndices) + call mct_aVect_copy(aVin=a2x_i, aVout=x2i_i, vector=mct_usevector, sharedIndices=a2x_SharedIndices) + call mct_aVect_copy(aVin=g2x_i, aVout=x2i_i, vector=mct_usevector, sharedIndices=g2x_SharedIndices) + + ! Merge total snow and precip for ice input + ! Scale total precip and runoff by flux_epbalfact + + do i = 1,lsize + x2i_i%rAttr(index_x2i_Faxa_rain,i) = a2x_i%rAttr(index_a2x_Faxa_rainc,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl,i) + x2i_i%rAttr(index_x2i_Faxa_snow,i) = a2x_i%rAttr(index_a2x_Faxa_snowc,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl,i) + x2i_i%rAttr(index_x2i_Fixx_rofi,i) = g2x_i%rAttr(index_g2x_Figg_rofi,i) + & + r2x_i%rAttr(index_r2x_Firr_rofi,i) + + x2i_i%rAttr(index_x2i_Faxa_rain,i) = x2i_i%rAttr(index_x2i_Faxa_rain,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow,i) = x2i_i%rAttr(index_x2i_Faxa_snow,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Fixx_rofi,i) = x2i_i%rAttr(index_x2i_Fixx_rofi,i) * flux_epbalfact + + ! For water isotopes + if ( index_x2i_Faxa_rain_16O /= 0 ) then + x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_16O,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_16O,i) + x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_16O,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_16O,i) + + x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) = x2i_i%rAttr(index_x2i_Faxa_rain_16O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) = x2i_i%rAttr(index_x2i_Faxa_snow_16O,i) * flux_epbalfact + end if + if ( index_x2i_Faxa_rain_18O /= 0 ) then + x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_18O,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_18O,i) + x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_18O,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_18O,i) + + x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) = x2i_i%rAttr(index_x2i_Faxa_rain_18O,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) = x2i_i%rAttr(index_x2i_Faxa_snow_18O,i) * flux_epbalfact + end if + if ( index_x2i_Faxa_rain_HDO /= 0 ) then + x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) = a2x_i%rAttr(index_a2x_Faxa_rainc_HDO,i) + & + a2x_i%rAttr(index_a2x_Faxa_rainl_HDO,i) + x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) = a2x_i%rAttr(index_a2x_Faxa_snowc_HDO,i) + & + a2x_i%rAttr(index_a2x_Faxa_snowl_HDO,i) + + x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) = x2i_i%rAttr(index_x2i_Faxa_rain_HDO,i) * flux_epbalfact + x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) = x2i_i%rAttr(index_x2i_Faxa_snow_HDO,i) * flux_epbalfact + end if + + end do + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do i = 1,niflds + write(logunit,'(A)') trim(mrgstr(i)) + enddo + endif + deallocate(mrgstr) + endif + + first_time = .false. + + end subroutine prep_ice_merge + + !================================================================================================ + + subroutine prep_ice_calc_a2x_ix(a2x_ox, timer) + !--------------------------------------------------------------- + ! Description + ! Create a2x_ix (note that a2x_ix is a local module variable) + ! + ! Arguments + type(mct_aVect) , intent(in) :: a2x_ox(:) + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eai + character(*), parameter :: subname = '(prep_ice_calc_a2x_ix)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eai = 1,num_inst_atm + call seq_map_map(mapper_SFo2i, a2x_ox(eai), a2x_ix(eai), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ice_calc_a2x_ix + + !================================================================================================ + + subroutine prep_ice_calc_o2x_ix(timer) + !--------------------------------------------------------------- + ! Description + ! Create o2x_ix (note that o2x_ix is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eoi + type(mct_aVect) , pointer :: o2x_ox + character(*), parameter :: subname = '(prep_ice_calc_o2x_ix)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eoi = 1,num_inst_ocn + o2x_ox => component_get_c2x_cx(ocn(eoi)) + call seq_map_map(mapper_SFo2i, o2x_ox, o2x_ix(eoi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ice_calc_o2x_ix + + !================================================================================================ + + subroutine prep_ice_calc_r2x_ix(timer) + !--------------------------------------------------------------- + ! Description + ! Create r2x_ix (note that r2x_ix is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eri + type(mct_aVect), pointer :: r2x_rx + character(*), parameter :: subname = '(prep_ice_calc_r2x_ix)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + r2x_rx => component_get_c2x_cx(rof(eri)) + + call seq_map_map(mapper_Rr2i, r2x_rx, r2x_ix(eri), & + fldlist='Firr_rofi', norm=.false.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ice_calc_r2x_ix + + !================================================================================================ + + subroutine prep_ice_calc_g2x_ix(timer) + !--------------------------------------------------------------- + ! Description + ! Create g2x_ix (note that g2x_ix is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: egi + type(mct_aVect), pointer :: g2x_gx + character(*), parameter :: subname = '(prep_ice_calc_g2x_ix)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do egi = 1,num_inst_glc + g2x_gx => component_get_c2x_cx(glc(egi)) + call seq_map_map(mapper_Rg2i, g2x_gx, g2x_ix(egi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ice_calc_g2x_ix + + !================================================================================================ + + function prep_ice_get_a2x_ix() + type(mct_aVect), pointer :: prep_ice_get_a2x_ix(:) + prep_ice_get_a2x_ix => a2x_ix(:) + end function prep_ice_get_a2x_ix + + function prep_ice_get_o2x_ix() + type(mct_aVect), pointer :: prep_ice_get_o2x_ix(:) + prep_ice_get_o2x_ix => o2x_ix(:) + end function prep_ice_get_o2x_ix + + function prep_ice_get_g2x_ix() + type(mct_aVect), pointer :: prep_ice_get_g2x_ix(:) + prep_ice_get_g2x_ix => g2x_ix(:) + end function prep_ice_get_g2x_ix + + function prep_ice_get_r2x_ix() + type(mct_aVect), pointer :: prep_ice_get_r2x_ix(:) + prep_ice_get_r2x_ix => r2x_ix(:) + end function prep_ice_get_r2x_ix + + function prep_ice_get_mapper_SFo2i() + type(seq_map), pointer :: prep_ice_get_mapper_SFo2i + prep_ice_get_mapper_SFo2i => mapper_SFo2i + end function prep_ice_get_mapper_SFo2i + + function prep_ice_get_mapper_Rg2i() + type(seq_map), pointer :: prep_ice_get_mapper_Rg2i + prep_ice_get_mapper_Rg2i => mapper_Rg2i + end function prep_ice_get_mapper_Rg2i + +end module prep_ice_mod diff --git a/driver-mct/main/prep_lnd_mod.F90 b/driver-mct/main/prep_lnd_mod.F90 new file mode 100644 index 000000000000..74282df13565 --- /dev/null +++ b/driver-mct/main/prep_lnd_mod.F90 @@ -0,0 +1,520 @@ +module prep_lnd_mod + + use shr_kind_mod , only: r8 => SHR_KIND_R8 + use shr_kind_mod , only: cs => SHR_KIND_CS + use shr_kind_mod , only: cl => SHR_KIND_CL + use shr_kind_mod , only: cxx => SHR_KIND_CXX + use shr_sys_mod , only: shr_sys_abort, shr_sys_flush + use seq_comm_mct , only: num_inst_atm, num_inst_rof, num_inst_glc + use seq_comm_mct , only: num_inst_lnd, num_inst_frc + use seq_comm_mct , only: CPLID, LNDID, logunit + use seq_comm_mct , only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: lnd, atm, rof, glc + use map_glc2lnd_mod , only: map_glc2lnd_ec + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_lnd_init + public :: prep_lnd_mrg + + public :: prep_lnd_calc_a2x_lx + public :: prep_lnd_calc_r2x_lx + public :: prep_lnd_calc_g2x_lx + + public :: prep_lnd_get_a2x_lx + public :: prep_lnd_get_r2x_lx + public :: prep_lnd_get_g2x_lx + + public :: prep_lnd_get_mapper_Sa2l + public :: prep_lnd_get_mapper_Fa2l + public :: prep_lnd_get_mapper_Fr2l + public :: prep_lnd_get_mapper_Sg2l + public :: prep_lnd_get_mapper_Fg2l + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_lnd_merge + private :: prep_lnd_set_glc2lnd_fields + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_Sa2l ! needed in ccsm_comp_mod.F90 (setting of aream) + type(seq_map), pointer :: mapper_Fa2l ! needed in ccsm_comp_mod.F90 (seq_domain_check) + type(seq_map), pointer :: mapper_Fr2l ! needed in seq_frac_mct.F90 + type(seq_map), pointer :: mapper_Sg2l ! currently unused (all g2l mappings use the flux mapper) + type(seq_map), pointer :: mapper_Fg2l + + ! attribute vectors + type(mct_aVect), pointer :: a2x_lx(:) ! Atm export, lnd grid, cpl pes - allocated in driver + type(mct_aVect), pointer :: r2x_lx(:) ! Rof export, lnd grid, lnd pes - allocated in lnd gc + type(mct_aVect), pointer :: g2x_lx(:) ! Glc export, lnd grid, cpl pes - allocated in driver + + ! seq_comm_getData variables + integer :: mpicom_CPLID ! MPI cpl communicator + + ! field names and lists, for fields that need to be treated specially + character(len=*), parameter :: glc_frac_field = 'Sg_ice_covered' + character(len=*), parameter :: glc_topo_field = 'Sg_topo' + character(len=*), parameter :: glc_icemask_field = 'Sg_icemask' + ! fields mapped from glc to lnd, NOT separated by elevation class + character(CXX) :: glc2lnd_non_ec_fields + ! other fields (besides frac_field and topo_field) that are mapped from glc to lnd, + ! separated by elevation class + character(CXX) :: glc2lnd_ec_extra_fields + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_lnd_init(infodata, atm_c2_lnd, rof_c2_lnd, glc_c2_lnd) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and all other non-mapping + ! module variables + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in) :: atm_c2_lnd ! .true. => atm to lnd coupling on + logical , intent(in) :: rof_c2_lnd ! .true. => rof to lnd coupling on + logical , intent(in) :: glc_c2_lnd ! .true. => glc to lnd coupling on + ! + ! Local Variables + integer :: lsize_l + integer :: eai, eri, egi, eli + logical :: samegrid_al ! samegrid atm and land + logical :: samegrid_lr ! samegrid land and rof + logical :: samegrid_lg ! samegrid land and glc + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: lnd_present ! .true. => land is present + logical :: iamroot_CPLID ! .true. => CPLID masterproc + character(CL) :: atm_gnam ! atm grid + character(CL) :: lnd_gnam ! lnd grid + character(CL) :: rof_gnam ! rof grid + character(CL) :: glc_gnam ! glc grid + type(mct_avect), pointer :: l2x_lx + character(*), parameter :: subname = '(prep_lnd_init)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + esmf_map_flag=esmf_map_flag, & + lnd_present=lnd_present, & + atm_gnam=atm_gnam, & + lnd_gnam=lnd_gnam, & + rof_gnam=rof_gnam, & + glc_gnam=glc_gnam) + + allocate(mapper_Sa2l) + allocate(mapper_Fa2l) + allocate(mapper_Fr2l) + allocate(mapper_Sg2l) + allocate(mapper_Fg2l) + + if (lnd_present) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + l2x_lx => component_get_c2x_cx(lnd(1)) + lsize_l = mct_aVect_lsize(l2x_lx) + + allocate(a2x_lx(num_inst_atm)) + do eai = 1,num_inst_atm + call mct_aVect_init(a2x_lx(eai), rList=seq_flds_a2x_fields, lsize=lsize_l) + call mct_aVect_zero(a2x_lx(eai)) + enddo + allocate(r2x_lx(num_inst_rof)) + do eri = 1,num_inst_rof + call mct_aVect_init(r2x_lx(eri), rlist=seq_flds_r2x_fields, lsize=lsize_l) + call mct_aVect_zero(r2x_lx(eri)) + end do + allocate(g2x_lx(num_inst_glc)) + do egi = 1,num_inst_glc + call mct_aVect_init(g2x_lx(egi), rList=seq_flds_x2l_fields_from_glc, lsize=lsize_l) + call mct_aVect_zero(g2x_lx(egi)) + end do + + samegrid_al = .true. + samegrid_lr = .true. + samegrid_lg = .true. + if (trim(atm_gnam) /= trim(lnd_gnam)) samegrid_al = .false. + if (trim(lnd_gnam) /= trim(rof_gnam)) samegrid_lr = .false. + if (trim(lnd_gnam) /= trim(glc_gnam)) samegrid_lg = .false. + + if (rof_c2_lnd) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fr2l' + end if + call seq_map_init_rcfile(mapper_Fr2l, rof(1), lnd(1), & + 'seq_maps.rc','rof2lnd_fmapname:','rof2lnd_fmaptype:',samegrid_lr, & + string='mapper_Fr2l initialization',esmf_map=esmf_map_flag) + end if + call shr_sys_flush(logunit) + + if (atm_c2_lnd) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sa2l' + end if + call seq_map_init_rcfile(mapper_Sa2l, atm(1), lnd(1), & + 'seq_maps.rc','atm2lnd_smapname:','atm2lnd_smaptype:',samegrid_al, & + 'mapper_Sa2l initialization',esmf_map_flag) + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fa2l' + end if + call seq_map_init_rcfile(mapper_Fa2l, atm(1), lnd(1), & + 'seq_maps.rc','atm2lnd_fmapname:','atm2lnd_fmaptype:',samegrid_al, & + 'mapper_Fa2l initialization',esmf_map_flag) + endif + call shr_sys_flush(logunit) + + if (glc_c2_lnd) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sg2l' + end if + call seq_map_init_rcfile(mapper_Sg2l, glc(1), lnd(1), & + 'seq_maps.rc','glc2lnd_smapname:','glc2lnd_smaptype:',samegrid_lg, & + 'mapper_Sg2l initialization',esmf_map_flag) + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fg2l' + end if + call seq_map_init_rcfile(mapper_Fg2l, glc(1), lnd(1), & + 'seq_maps.rc','glc2lnd_fmapname:','glc2lnd_fmaptype:',samegrid_lg, & + 'mapper_Fg2l initialization',esmf_map_flag) + + call prep_lnd_set_glc2lnd_fields() + endif + call shr_sys_flush(logunit) + + end if + + end subroutine prep_lnd_init + + !================================================================================================ + + subroutine prep_lnd_set_glc2lnd_fields() + + !--------------------------------------------------------------- + ! Description + ! Sets the module-level glc2lnd_non_ec_fields and glc2lnd_ec_extra_fields variables. + ! + ! Local Variables + character(len=CXX) :: temp_list + + character(*), parameter :: subname = '(prep_lnd_set_glc2lnd_fields)' + !--------------------------------------------------------------- + + ! glc2lnd fields not separated by elevation class can be determined by finding fields + ! that exist in both the g2x_to_lnd list and the x2l_from_glc list + call shr_string_listIntersect(seq_flds_g2x_fields_to_lnd, & + seq_flds_x2l_fields_from_glc, & + glc2lnd_non_ec_fields) + + ! glc2lnd fields separated by elevation class are all fields not determined above. + ! However, we also need to remove glc_frac_field and glc_topo_field from this list, + ! because those are handled specially, so are not expected to be in this + ! "extra_fields" list. + ! + ! NOTE(wjs, 2015-04-24) I am going to the trouble of building this field list + ! dynamically, rather than simply hard-coding the necessary fields (currently just + ! 'Flgg_hflx'), so that new fields can be added in seq_flds_mod without needing to + ! change any other code. + call shr_string_listDiff(seq_flds_g2x_fields_to_lnd, & + glc2lnd_non_ec_fields, & + glc2lnd_ec_extra_fields) + temp_list = glc2lnd_ec_extra_fields + call shr_string_listDiff(temp_list, & + glc_frac_field, & + glc2lnd_ec_extra_fields) + temp_list = glc2lnd_ec_extra_fields + call shr_string_listDiff(temp_list, & + glc_topo_field, & + glc2lnd_ec_extra_fields) + + end subroutine prep_lnd_set_glc2lnd_fields + + !================================================================================================ + + subroutine prep_lnd_mrg(infodata, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Prepare run phase, including running the merge + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eai, eri, egi, eli, efi + type(mct_aVect), pointer :: x2l_lx + character(*), parameter :: subname = '(prep_lnd_mrg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_mrg),barrier=mpicom_CPLID) + do eli = 1,num_inst_lnd + ! Use fortran mod to address ensembles in merge + eai = mod((eli-1),num_inst_atm) + 1 + eri = mod((eli-1),num_inst_rof) + 1 + egi = mod((eli-1),num_inst_glc) + 1 + + x2l_lx => component_get_x2c_cx(lnd(eli)) ! This is actually modifying x2l_lx + call prep_lnd_merge( a2x_lx(eai), r2x_lx(eri), g2x_lx(egi), x2l_lx ) + enddo + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_lnd_mrg + + !================================================================================================ + + subroutine prep_lnd_merge( a2x_l, r2x_l, g2x_l, x2l_l ) + !--------------------------------------------------------------- + ! Description + ! Create input land state directly from atm, runoff and glc outputs + ! + ! Arguments + type(mct_aVect), intent(in) :: a2x_l + type(mct_aVect), intent(in) :: r2x_l + type(mct_aVect), intent(in) :: g2x_l + type(mct_aVect), intent(inout) :: x2l_l + !----------------------------------------------------------------------- + integer :: nflds,i,i1,o1 + logical :: iamroot + logical, save :: first_time = .true. + character(CL),allocatable :: mrgstr(:) ! temporary string + character(CL) :: field ! string converted to char + type(mct_aVect_sharedindices),save :: a2x_sharedindices + type(mct_aVect_sharedindices),save :: r2x_sharedindices + type(mct_aVect_sharedindices),save :: g2x_sharedindices + character(*), parameter :: subname = '(prep_lnd_merge) ' + + !----------------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + + if (first_time) then + nflds = mct_aVect_nRattr(x2l_l) + + allocate(mrgstr(nflds)) + do i = 1,nflds + field = mct_aVect_getRList2c(i, x2l_l) + mrgstr(i) = subname//'x2l%'//trim(field)//' =' + enddo + + call mct_aVect_setSharedIndices(a2x_l, x2l_l, a2x_SharedIndices) + call mct_aVect_setSharedIndices(r2x_l, x2l_l, r2x_SharedIndices) + call mct_aVect_setSharedIndices(g2x_l, x2l_l, g2x_SharedIndices) + + !--- document copy operations --- + do i=1,a2x_SharedIndices%shared_real%num_indices + i1=a2x_SharedIndices%shared_real%aVindices1(i) + o1=a2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, a2x_l) + mrgstr(o1) = trim(mrgstr(o1))//' = a2x%'//trim(field) + enddo + do i=1,r2x_SharedIndices%shared_real%num_indices + i1=r2x_SharedIndices%shared_real%aVindices1(i) + o1=r2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, r2x_l) + mrgstr(o1) = trim(mrgstr(o1))//' = r2x%'//trim(field) + enddo + do i=1,g2x_SharedIndices%shared_real%num_indices + i1=g2x_SharedIndices%shared_real%aVindices1(i) + o1=g2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, g2x_l) + mrgstr(o1) = trim(mrgstr(o1))//' = g2x%'//trim(field) + enddo + endif + + call mct_aVect_copy(aVin=a2x_l, aVout=x2l_l, vector=mct_usevector, sharedIndices=a2x_SharedIndices) + call mct_aVect_copy(aVin=r2x_l, aVout=x2l_l, vector=mct_usevector, sharedIndices=r2x_SharedIndices) + call mct_aVect_copy(aVin=g2x_l, aVout=x2l_l, vector=mct_usevector, sharedIndices=g2x_SharedIndices) + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do i = 1,nflds + write(logunit,'(A)') trim(mrgstr(i)) + enddo + endif + deallocate(mrgstr) + endif + + first_time = .false. + + end subroutine prep_lnd_merge + + !================================================================================================ + + subroutine prep_lnd_calc_a2x_lx(timer) + !--------------------------------------------------------------- + ! Description + ! Create a2x_lx (note that a2x_lx is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eai + type(mct_aVect), pointer :: a2x_ax + character(*), parameter :: subname = '(prep_lnd_calc_a2x_lx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eai = 1,num_inst_atm + a2x_ax => component_get_c2x_cx(atm(eai)) + call seq_map_map(mapper_Fa2l, a2x_ax, a2x_lx(eai), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_lnd_calc_a2x_lx + + !================================================================================================ + + subroutine prep_lnd_calc_r2x_lx(timer) + !--------------------------------------------------------------- + ! Description + ! Create r2x_lx (note that r2x_lx is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eri + type(mct_aVect) , pointer :: r2x_rx + character(*), parameter :: subname = '(prep_lnd_calc_r2x_lx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + r2x_rx => component_get_c2x_cx(rof(eri)) + + ! Note that one of these fields (a volr field) is remapped from rof -> lnd in + ! map_lnd2rof_irrig_mod, because it is needed as a normalization term. So, if the + ! details of this mapping call are changed in the future, it's possible that the + ! equivalent r2l mapping in map_lnd2rof_irrig_mod should be changed to keep the two + ! equivalent. + call seq_map_map(mapper_Fr2l, r2x_rx, r2x_lx(eri), & + fldlist=seq_flds_r2x_fluxes, norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_lnd_calc_r2x_lx + + !================================================================================================ + + subroutine prep_lnd_calc_g2x_lx(timer) + !--------------------------------------------------------------- + ! Description + ! Create g2x_lx (note that g2x_lx is a local module variable) + ! + ! Arguments + character(len=*) , intent(in) :: timer + ! + ! Local Variables + integer :: egi + type(mct_aVect), pointer :: g2x_gx + character(*), parameter :: subname = '(prep_lnd_calc_g2x_lx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do egi = 1,num_inst_glc + g2x_gx => component_get_c2x_cx(glc(egi)) + + ! Map fields that are NOT separated by elevation class on the land grid + ! + ! These are mapped using a simple area-conservative remapping. (Note that we use + ! the flux mapper even though these contain states, because we need these icemask + ! fields to be mapped conservatively.) + ! + ! Note that this mapping is redone for Sg_icemask in prep_glc_mod: + ! prep_glc_map_qice_conservative_lnd2glc. If we ever change this mapping (e.g., + ! changing norm to .false.), then we should change the mapping there, too. + ! + ! BUG(wjs, 2017-05-11, #1516) I think we actually want norm = .false. here, but + ! this requires some more thought + call seq_map_map(mapper_Fg2l, g2x_gx, g2x_lx(egi), & + fldlist = glc2lnd_non_ec_fields, norm=.true.) + + ! Map fields that are separated by elevation class on the land grid + call map_glc2lnd_ec( & + g2x_g = g2x_gx, & + frac_field = glc_frac_field, & + topo_field = glc_topo_field, & + icemask_field = glc_icemask_field, & + extra_fields = glc2lnd_ec_extra_fields, & + mapper = mapper_Fg2l, & + g2x_l = g2x_lx(egi)) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_lnd_calc_g2x_lx + + !================================================================================================ + + function prep_lnd_get_a2x_lx() + type(mct_aVect), pointer :: prep_lnd_get_a2x_lx(:) + prep_lnd_get_a2x_lx => a2x_lx(:) + end function prep_lnd_get_a2x_lx + + function prep_lnd_get_r2x_lx() + type(mct_aVect), pointer :: prep_lnd_get_r2x_lx(:) + prep_lnd_get_r2x_lx => r2x_lx(:) + end function prep_lnd_get_r2x_lx + + function prep_lnd_get_g2x_lx() + type(mct_aVect), pointer :: prep_lnd_get_g2x_lx(:) + prep_lnd_get_g2x_lx => g2x_lx(:) + end function prep_lnd_get_g2x_lx + + function prep_lnd_get_mapper_Sa2l() + type(seq_map), pointer :: prep_lnd_get_mapper_Sa2l + prep_lnd_get_mapper_Sa2l => mapper_Sa2l + end function prep_lnd_get_mapper_Sa2l + + function prep_lnd_get_mapper_Fa2l() + type(seq_map), pointer :: prep_lnd_get_mapper_Fa2l + prep_lnd_get_mapper_Fa2l => mapper_Fa2l + end function prep_lnd_get_mapper_Fa2l + + function prep_lnd_get_mapper_Fr2l() + type(seq_map), pointer :: prep_lnd_get_mapper_Fr2l + prep_lnd_get_mapper_Fr2l => mapper_Fr2l + end function prep_lnd_get_mapper_Fr2l + + function prep_lnd_get_mapper_Sg2l() + type(seq_map), pointer :: prep_lnd_get_mapper_Sg2l + prep_lnd_get_mapper_Sg2l => mapper_Sg2l + end function prep_lnd_get_mapper_Sg2l + + function prep_lnd_get_mapper_Fg2l() + type(seq_map), pointer :: prep_lnd_get_mapper_Fg2l + prep_lnd_get_mapper_Fg2l => mapper_Fg2l + end function prep_lnd_get_mapper_Fg2l + +end module prep_lnd_mod diff --git a/driver-mct/main/prep_ocn_mod.F90 b/driver-mct/main/prep_ocn_mod.F90 new file mode 100644 index 000000000000..ac90d9a1518a --- /dev/null +++ b/driver-mct/main/prep_ocn_mod.F90 @@ -0,0 +1,1348 @@ +module prep_ocn_mod + + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use seq_comm_mct, only: num_inst_atm, num_inst_rof, num_inst_ice + use seq_comm_mct, only: num_inst_glc, num_inst_wav, num_inst_ocn + use seq_comm_mct, only: num_inst_xao, num_inst_frc + use seq_comm_mct, only: num_inst_max + use seq_comm_mct, only: CPLID, OCNID, logunit + use seq_comm_mct, only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: ocn, atm, ice, rof, wav, glc + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_ocn_init + public :: prep_ocn_mrg + + public :: prep_ocn_accum + public :: prep_ocn_accum_avg + + public :: prep_ocn_calc_a2x_ox + public :: prep_ocn_calc_i2x_ox + public :: prep_ocn_calc_r2x_ox + public :: prep_ocn_calc_g2x_ox + public :: prep_ocn_calc_w2x_ox + + public :: prep_ocn_get_a2x_ox + public :: prep_ocn_get_r2x_ox + public :: prep_ocn_get_i2x_ox + public :: prep_ocn_get_g2x_ox + public :: prep_ocn_get_w2x_ox + + public :: prep_ocn_get_x2oacc_ox + public :: prep_ocn_get_x2oacc_ox_cnt + + public :: prep_ocn_get_mapper_Sa2o + public :: prep_ocn_get_mapper_Va2o + public :: prep_ocn_get_mapper_Fa2o + public :: prep_ocn_get_mapper_Fr2o + public :: prep_ocn_get_mapper_Rr2o_liq + public :: prep_ocn_get_mapper_Rr2o_ice + public :: prep_ocn_get_mapper_SFi2o + public :: prep_ocn_get_mapper_Rg2o + public :: prep_ocn_get_mapper_Sw2o + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_ocn_merge + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_Sa2o + type(seq_map), pointer :: mapper_Va2o + type(seq_map), pointer :: mapper_Fa2o + type(seq_map), pointer :: mapper_Fr2o + type(seq_map), pointer :: mapper_Rr2o_liq + type(seq_map), pointer :: mapper_Rr2o_ice + type(seq_map), pointer :: mapper_SFi2o + type(seq_map), pointer :: mapper_Rg2o + type(seq_map), pointer :: mapper_Sw2o + + ! attribute vectors + type(mct_aVect), pointer :: a2x_ox(:) ! Atm export, ocn grid, cpl pes + type(mct_aVect), pointer :: r2x_ox(:) ! Rof export, ocn grid, cpl pes + type(mct_aVect), pointer :: i2x_ox(:) ! Ice export, ocn grid, cpl pes + type(mct_aVect), pointer :: g2x_ox(:) ! Glc export, ocn grid, cpl pes + type(mct_aVect), pointer :: w2x_ox(:) ! Wav export, ocn grid, cpl pes + + type(mct_aVect), target :: x2o_ox_inst ! multi instance for averaging + + ! accumulation variables + type(mct_aVect), pointer :: x2oacc_ox(:) ! Ocn import, ocn grid, cpl pes + integer , target :: x2oacc_ox_cnt ! x2oacc_ox: number of time samples accumulated + + ! other module variables + integer :: mpicom_CPLID ! MPI cpl communicator + logical :: flood_present ! .true. => rof is computing flood + character(CS) :: vect_map ! vector mapping type + logical :: x2o_average ! logical for x2o averaging to 1 ocean instance from multi instances + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_ocn_init(infodata, atm_c2_ocn, atm_c2_ice, ice_c2_ocn, rof_c2_ocn, & + wav_c2_ocn, glc_c2_ocn) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and all other non-mapping + ! module variables except for accumulators + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in) :: atm_c2_ocn ! .true.=>atm to ocn coupling on + logical , intent(in) :: atm_c2_ice ! .true.=>atm to ice coupling on + logical , intent(in) :: ice_c2_ocn ! .true.=>ice to ocn coupling on + logical , intent(in) :: rof_c2_ocn ! .true.=>rof to ocn coupling on + logical , intent(in) :: wav_c2_ocn ! .true.=>wav to ocn coupling on + logical , intent(in) :: glc_c2_ocn ! .true.=>glc to ocn coupling on + ! + ! Local Variables + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: ocn_present ! .true. => ocn is present + logical :: atm_present ! .true. => atm is present + logical :: ice_present ! .true. => ice is present + logical :: iamroot_CPLID ! .true. => CPLID masterproc + logical :: samegrid_ao ! samegrid atm and ocean + logical :: samegrid_og ! samegrid glc and ocean + logical :: samegrid_ow ! samegrid ocean and wave + logical :: samegrid_ro ! samegrid runoff and ocean + integer :: atm_nx, atm_ny + integer :: lsize_o + integer :: eli, egi, eri + integer :: ewi, eai, eii, eoi + integer :: ka,km,k1,k2,k3 ! aVect field indices + character(CL) :: ocn_gnam ! ocn grid + character(CL) :: atm_gnam ! atm grid + character(CL) :: rof_gnam ! rof grid + character(CL) :: wav_gnam ! wav grid + character(CL) :: glc_gnam ! glc grid + type(mct_avect), pointer :: o2x_ox + type(mct_avect), pointer :: x2o_ox + character(*), parameter :: subname = '(prep_ocn_init)' + character(*), parameter :: F00 = "('"//subname//" : ', 4A )" + character(*), parameter :: F01 = "('"//subname//" : ', A, I8 )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata , & + ocn_present=ocn_present , & + atm_present=atm_present , & + ice_present=ice_present , & + flood_present=flood_present , & + vect_map=vect_map , & + atm_gnam=atm_gnam , & + ocn_gnam=ocn_gnam , & + rof_gnam=rof_gnam , & + wav_gnam=wav_gnam , & + atm_nx=atm_nx , & + atm_ny=atm_ny , & + glc_gnam=glc_gnam , & + esmf_map_flag=esmf_map_flag ) + + allocate(mapper_Sa2o) + allocate(mapper_Va2o) + allocate(mapper_Fa2o) + allocate(mapper_Fr2o) + allocate(mapper_Rr2o_liq) + allocate(mapper_Rr2o_ice) + allocate(mapper_SFi2o) + allocate(mapper_Rg2o) + allocate(mapper_Sw2o) + + if (ocn_present) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + o2x_ox => component_get_c2x_cx(ocn(1)) + x2o_ox => component_get_x2c_cx(ocn(1)) + lsize_o = mct_aVect_lsize(o2x_ox) + + ! x2o_average setup logic + if (num_inst_max == num_inst_ocn) then + ! standard multi-instance merge + x2o_average = .false. + elseif (num_inst_max > 1 .and. num_inst_ocn == 1) then + ! averaging ocean merge + x2o_average = .true. + if (iamroot_CPLID) then + write(logunit,F01) 'x2o averaging on over instances =',num_inst_max + end if + call mct_aVect_init(x2o_ox_inst, x2o_ox, lsize_o) + call mct_aVect_zero(x2o_ox_inst) + else + ! not allowed + write(logunit,F00) ' ERROR in x2o_average setup logic ' + call shr_sys_abort(subname//' ERROR in x2o_average setup logic') + endif + + allocate(a2x_ox(num_inst_atm)) + do eai = 1,num_inst_atm + call mct_aVect_init(a2x_ox(eai), rList=seq_flds_a2x_fields, lsize=lsize_o) + call mct_aVect_zero(a2x_ox(eai)) + enddo + allocate(r2x_ox(num_inst_rof)) + do eri = 1,num_inst_rof + call mct_aVect_init(r2x_ox(eri), rList=seq_flds_r2x_fields, lsize=lsize_o) + call mct_aVect_zero(r2x_ox(eri)) + enddo + allocate(g2x_ox(num_inst_glc)) + do egi = 1,num_inst_glc + call mct_aVect_init(g2x_ox(egi), rList=seq_flds_g2x_fields, lsize=lsize_o) + call mct_aVect_zero(g2x_ox(egi)) + end do + allocate(w2x_ox(num_inst_wav)) + do ewi = 1,num_inst_wav + call mct_aVect_init(w2x_ox(ewi), rList=seq_flds_w2x_fields, lsize=lsize_o) + call mct_aVect_zero(w2x_ox(ewi)) + enddo + allocate(i2x_ox(num_inst_ice)) + do eii = 1,num_inst_ice + call mct_aVect_init(i2x_ox(eii), rList=seq_flds_i2x_fields, lsize=lsize_o) + call mct_aVect_zero(i2x_ox(eii)) + enddo + + allocate(x2oacc_ox(num_inst_ocn)) + do eoi = 1,num_inst_ocn + call mct_avect_init(x2oacc_ox(eoi), x2o_ox, lsize_o) + call mct_aVect_zero(x2oacc_ox(eoi)) + end do + x2oacc_ox_cnt = 0 + + samegrid_ao = .true. + samegrid_ro = .true. + samegrid_ow = .true. + samegrid_og = .true. + if (trim(atm_gnam) /= trim(ocn_gnam)) samegrid_ao = .false. + if (trim(rof_gnam) /= trim(ocn_gnam)) samegrid_ro = .false. + if (trim(ocn_gnam) /= trim(wav_gnam)) samegrid_ow = .false. + if (trim(ocn_gnam) /= trim(glc_gnam)) samegrid_og = .false. + + if (atm_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fa2o' + end if + call seq_map_init_rcfile(mapper_Fa2o, atm(1), ocn(1), & + 'seq_maps.rc','atm2ocn_fmapname:','atm2ocn_fmaptype:',samegrid_ao, & + 'mapper_Fa2o initialization',esmf_map_flag) + call shr_sys_flush(logunit) + end if + + ! atm_c2_ice flag is here because ice and ocn are constrained to be on the same + ! grid so the atm->ice mapping is set to the atm->ocn mapping to improve performance + if (atm_c2_ocn .or. atm_c2_ice) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sa2o' + end if + call seq_map_init_rcfile(mapper_Sa2o, atm(1), ocn(1), & + 'seq_maps.rc','atm2ocn_smapname:','atm2ocn_smaptype:',samegrid_ao, & + 'mapper_Sa2o initialization',esmf_map_flag) + + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Va2o' + end if + call seq_map_init_rcfile(mapper_Va2o, atm(1), ocn(1), & + 'seq_maps.rc','atm2ocn_vmapname:','atm2ocn_vmaptype:',samegrid_ao, & + 'mapper_Va2o initialization',esmf_map_flag) + + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Va2o vect' + end if + call seq_map_initvect(mapper_Va2o, vect_map, atm(1), ocn(1), string='mapper_Va2o initvect') + endif + call shr_sys_flush(logunit) + + ! needed for domain checking + if (ice_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_SFi2o' + end if + call seq_map_init_rearrolap(mapper_SFi2o, ice(1), ocn(1), 'mapper_SFi2o') + endif + call shr_sys_flush(logunit) + + if (rof_c2_ocn) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Rr2o_liq' + end if + call seq_map_init_rcfile(mapper_Rr2o_liq, rof(1), ocn(1), & + 'seq_maps.rc', 'rof2ocn_liq_rmapname:', 'rof2ocn_liq_rmaptype:',samegrid_ro, & + 'mapper_Rr2o_liq initialization',esmf_map_flag) + + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Rr2o_ice' + end if + call seq_map_init_rcfile(mapper_Rr2o_ice, rof(1), ocn(1), & + 'seq_maps.rc', 'rof2ocn_ice_rmapname:', 'rof2ocn_ice_rmaptype:',samegrid_ro, & + 'mapper_Rr2o_ice initialization',esmf_map_flag) + + if (flood_present) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fr2o' + end if + call seq_map_init_rcfile( mapper_Fr2o, rof(1), ocn(1), & + 'seq_maps.rc', 'rof2ocn_fmapname:', 'rof2ocn_fmaptype:',samegrid_ro, & + string='mapper_Fr2o initialization', esmf_map=esmf_map_flag) + endif + endif + call shr_sys_flush(logunit) + + if (glc_c2_ocn) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Rg2o' + end if + call seq_map_init_rcfile(mapper_Rg2o, glc(1), ocn(1), & + 'seq_maps.rc', 'glc2ocn_rmapname:', 'glc2ocn_rmaptype:',samegrid_og, & + 'mapper_Rg2o initialization',esmf_map_flag) + endif + call shr_sys_flush(logunit) + + if (wav_c2_ocn) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sw2o' + end if + call seq_map_init_rcfile(mapper_Sw2o, wav(1), ocn(1), & + 'seq_maps.rc', 'wav2ocn_smapname:', 'wav2ocn_smaptype:',samegrid_ow, & + 'mapper_Sw2o initialization') + endif + call shr_sys_flush(logunit) + + end if + + end subroutine prep_ocn_init + + !================================================================================================ + + subroutine prep_ocn_accum(timer) + !--------------------------------------------------------------- + ! Description + ! Accumulate ocn inputs + ! Form partial sum of tavg ocn inputs (virtual "send" to ocn) + ! NOTE: this is done AFTER the call to the merge in prep_ocn_mrg + ! + ! Arguments + character(len=*) , intent(in) :: timer + ! + ! Local Variables + integer :: eoi + type(mct_avect) , pointer :: x2o_ox + character(*) , parameter :: subname = '(prep_ocn_accum)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer), barrier=mpicom_CPLID) + do eoi = 1,num_inst_ocn + x2o_ox => component_get_x2c_cx(ocn(eoi)) + + if (x2oacc_ox_cnt == 0) then + call mct_avect_copy(x2o_ox, x2oacc_ox(eoi)) + else + call mct_avect_accum(x2o_ox, x2oacc_ox(eoi)) + endif + enddo + x2oacc_ox_cnt = x2oacc_ox_cnt + 1 + call t_drvstopf (trim(timer)) + + end subroutine prep_ocn_accum + + !================================================================================================ + + subroutine prep_ocn_accum_avg(timer_accum) + !--------------------------------------------------------------- + ! Description + ! Finish accumulation ocn inputs + ! + ! Arguments + character(len=*), intent(in) :: timer_accum + ! + ! Local Variables + integer :: eoi + type(mct_avect), pointer :: x2o_ox + character(*), parameter :: subname = '(prep_ocn_accum_avg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_accum), barrier=mpicom_CPLID) + do eoi = 1,num_inst_ocn + ! temporary formation of average + if (x2oacc_ox_cnt > 1) then + call mct_avect_avg(x2oacc_ox(eoi), x2oacc_ox_cnt) + end if + + ! ***NOTE***THE FOLLOWING ACTUALLY MODIFIES x2o_ox + x2o_ox => component_get_x2c_cx(ocn(eoi)) + call mct_avect_copy(x2oacc_ox(eoi), x2o_ox) + enddo + x2oacc_ox_cnt = 0 + call t_drvstopf (trim(timer_accum)) + + end subroutine prep_ocn_accum_avg + + !================================================================================================ + + subroutine prep_ocn_mrg(infodata, fractions_ox, xao_ox, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Merge all ocn inputs + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type(mct_aVect) , intent(in) :: fractions_ox(:) + type(mct_aVect) , intent(in) :: xao_ox(:) ! Atm-ocn fluxes, ocn grid, cpl pes + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eii, ewi, egi, eoi, eai, eri, exi, efi, emi + real(r8) :: flux_epbalfact ! adjusted precip factor + type(mct_avect), pointer :: x2o_ox + integer :: cnt + character(*), parameter :: subname = '(prep_ocn_mrg)' + !--------------------------------------------------------------- + + call seq_infodata_GetData(infodata, & + flux_epbalfact=flux_epbalfact) + + call t_drvstartf (trim(timer_mrg), barrier=mpicom_CPLID) + + ! Use emi here for instance averaging capability, num_inst_max = num_inst_ocn normally + ! if NOT x2o_average, just fill each instance of component_get_x2c_cx(ocn(eoi)) + ! if x2o_average, then computer merge into x2o_ox_inst and accumulate that to + ! component_get_x2c_cx(ocn(1)) and then average it at the end + + if (x2o_average) then + x2o_ox => component_get_x2c_cx(ocn(1)) + call mct_aVect_zero(x2o_ox) + endif + + cnt = 0 + do emi = 1,num_inst_max + ! Use fortran mod to address ensembles in merge + eoi = mod((emi-1),num_inst_ocn) + 1 + eai = mod((emi-1),num_inst_atm) + 1 + eii = mod((emi-1),num_inst_ice) + 1 + eri = mod((emi-1),num_inst_rof) + 1 + ewi = mod((emi-1),num_inst_wav) + 1 + egi = mod((emi-1),num_inst_glc) + 1 + exi = mod((emi-1),num_inst_xao) + 1 + efi = mod((emi-1),num_inst_frc) + 1 + + if (x2o_average) then + x2o_ox => x2o_ox_inst + else + x2o_ox => component_get_x2c_cx(ocn(eoi)) + endif + + call prep_ocn_merge( flux_epbalfact, a2x_ox(eai), i2x_ox(eii), r2x_ox(eri), & + w2x_ox(ewi), g2x_ox(egi), xao_ox(exi), fractions_ox(efi), x2o_ox ) + + if (x2o_average) then + x2o_ox => component_get_x2c_cx(ocn(1)) + call mct_aVect_accum(x2o_ox_inst, x2o_ox) + cnt = cnt + 1 + endif + enddo + + if (x2o_average) then + x2o_ox => component_get_x2c_cx(ocn(1)) + call mct_avect_avg(x2o_ox,cnt) + endif + + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_ocn_mrg + + !================================================================================================ + + subroutine prep_ocn_merge( flux_epbalfact, a2x_o, i2x_o, r2x_o, w2x_o, g2x_o, xao_o, & + fractions_o, x2o_o ) + + !----------------------------------------------------------------------- + ! + ! Arguments + real(r8) , intent(in) :: flux_epbalfact + type(mct_aVect), intent(in) :: a2x_o + type(mct_aVect), intent(in) :: i2x_o + type(mct_aVect), intent(in) :: r2x_o + type(mct_aVect), intent(in) :: w2x_o + type(mct_aVect), intent(in) :: g2x_o + type(mct_aVect), intent(in) :: xao_o + type(mct_aVect), intent(in) :: fractions_o + type(mct_aVect), intent(inout) :: x2o_o + ! + ! Local variables + integer :: n,ka,ki,ko,kr,kw,kx,kir,kor,i,i1,o1,ierr + integer :: kof,kif + integer :: lsize + integer :: noflds,naflds,niflds,nrflds,nwflds,nxflds + real(r8) :: ifrac,ifracr + real(r8) :: afrac,afracr + real(r8) :: frac_sum + real(r8) :: avsdr, anidr, avsdf, anidf ! albedos + real(r8) :: fswabsv, fswabsi ! sw + character(CL),allocatable :: field_ocn(:) ! string converted to char + character(CL),allocatable :: field_atm(:) ! string converted to char + character(CL),allocatable :: field_ice(:) ! string converted to char + character(CL),allocatable :: field_rof(:) ! string converted to char + character(CL),allocatable :: field_wav(:) ! string converted to char + character(CL),allocatable :: field_xao(:) ! string converted to char + character(CL),allocatable :: itemc_ocn(:) ! string converted to char + character(CL),allocatable :: itemc_atm(:) ! string converted to char + character(CL),allocatable :: itemc_ice(:) ! string converted to char + character(CL),allocatable :: itemc_rof(:) ! string converted to char + character(CL),allocatable :: itemc_wav(:) ! string converted to char + character(CL),allocatable :: itemc_xao(:) ! string converted to char + integer, save :: index_a2x_Faxa_swvdr + integer, save :: index_a2x_Faxa_swvdf + integer, save :: index_a2x_Faxa_swndr + integer, save :: index_a2x_Faxa_swndf + integer, save :: index_i2x_Fioi_swpen + integer, save :: index_xao_So_avsdr + integer, save :: index_xao_So_anidr + integer, save :: index_xao_So_avsdf + integer, save :: index_xao_So_anidf + integer, save :: index_a2x_Faxa_snowc + integer, save :: index_a2x_Faxa_snowl + integer, save :: index_a2x_Faxa_rainc + integer, save :: index_a2x_Faxa_rainl + integer, save :: index_r2x_Forr_rofl + integer, save :: index_r2x_Forr_rofi + integer, save :: index_r2x_Forr_rofl_16O + integer, save :: index_r2x_Forr_rofi_16O + integer, save :: index_r2x_Forr_rofl_18O + integer, save :: index_r2x_Forr_rofi_18O + integer, save :: index_r2x_Forr_rofl_HDO + integer, save :: index_r2x_Forr_rofi_HDO + integer, save :: index_r2x_Flrr_flood + integer, save :: index_g2x_Fogg_rofl + integer, save :: index_g2x_Fogg_rofi + integer, save :: index_x2o_Foxx_swnet + integer, save :: index_x2o_Faxa_snow + integer, save :: index_x2o_Faxa_rain + integer, save :: index_x2o_Faxa_prec + integer, save :: index_x2o_Foxx_rofl + integer, save :: index_x2o_Foxx_rofi + integer, save :: index_x2o_Sf_afrac + integer, save :: index_x2o_Sf_afracr + integer, save :: index_x2o_Foxx_swnet_afracr + integer, save :: index_x2o_Foxx_rofl_16O + integer, save :: index_x2o_Foxx_rofi_16O + integer, save :: index_x2o_Foxx_rofl_18O + integer, save :: index_x2o_Foxx_rofi_18O + integer, save :: index_x2o_Foxx_rofl_HDO + integer, save :: index_x2o_Foxx_rofi_HDO + integer, save :: index_a2x_Faxa_snowc_16O + integer, save :: index_a2x_Faxa_snowl_16O + integer, save :: index_a2x_Faxa_rainc_16O + integer, save :: index_a2x_Faxa_rainl_16O + integer, save :: index_x2o_Faxa_rain_16O + integer, save :: index_x2o_Faxa_snow_16O + integer, save :: index_x2o_Faxa_prec_16O + integer, save :: index_a2x_Faxa_snowc_18O + integer, save :: index_a2x_Faxa_snowl_18O + integer, save :: index_a2x_Faxa_rainc_18O + integer, save :: index_a2x_Faxa_rainl_18O + integer, save :: index_x2o_Faxa_rain_18O + integer, save :: index_x2o_Faxa_snow_18O + integer, save :: index_x2o_Faxa_prec_18O + integer, save :: index_a2x_Faxa_snowc_HDO + integer, save :: index_a2x_Faxa_snowl_HDO + integer, save :: index_a2x_Faxa_rainc_HDO + integer, save :: index_a2x_Faxa_rainl_HDO + integer, save :: index_x2o_Faxa_rain_HDO + integer, save :: index_x2o_Faxa_snow_HDO + integer, save :: index_x2o_Faxa_prec_HDO + logical :: iamroot + logical, save, pointer :: amerge(:),imerge(:),xmerge(:) + integer, save, pointer :: aindx(:), iindx(:), oindx(:), xindx(:) + character(CL),allocatable :: mrgstr(:) ! temporary string + type(mct_aVect_sharedindices),save :: a2x_sharedindices + type(mct_aVect_sharedindices),save :: i2x_sharedindices + type(mct_aVect_sharedindices),save :: r2x_sharedindices + type(mct_aVect_sharedindices),save :: w2x_sharedindices + type(mct_aVect_sharedindices),save :: xao_sharedindices + logical, save :: first_time = .true. + character(*),parameter :: subName = '(prep_ocn_merge) ' + !----------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID, iamroot=iamroot) + + noflds = mct_aVect_nRattr(x2o_o) + naflds = mct_aVect_nRattr(a2x_o) + niflds = mct_aVect_nRattr(i2x_o) + nrflds = mct_aVect_nRattr(r2x_o) + nwflds = mct_aVect_nRattr(w2x_o) + nxflds = mct_aVect_nRattr(xao_o) + + if (first_time) then + index_a2x_Faxa_swvdr = mct_aVect_indexRA(a2x_o,'Faxa_swvdr') + index_a2x_Faxa_swvdf = mct_aVect_indexRA(a2x_o,'Faxa_swvdf') + index_a2x_Faxa_swndr = mct_aVect_indexRA(a2x_o,'Faxa_swndr') + index_a2x_Faxa_swndf = mct_aVect_indexRA(a2x_o,'Faxa_swndf') + index_i2x_Fioi_swpen = mct_aVect_indexRA(i2x_o,'Fioi_swpen') + index_xao_So_avsdr = mct_aVect_indexRA(xao_o,'So_avsdr') + index_xao_So_anidr = mct_aVect_indexRA(xao_o,'So_anidr') + index_xao_So_avsdf = mct_aVect_indexRA(xao_o,'So_avsdf') + index_xao_So_anidf = mct_aVect_indexRA(xao_o,'So_anidf') + index_x2o_Foxx_swnet = mct_aVect_indexRA(x2o_o,'Foxx_swnet') + + index_a2x_Faxa_snowc = mct_aVect_indexRA(a2x_o,'Faxa_snowc') + index_a2x_Faxa_snowl = mct_aVect_indexRA(a2x_o,'Faxa_snowl') + index_a2x_Faxa_rainc = mct_aVect_indexRA(a2x_o,'Faxa_rainc') + index_a2x_Faxa_rainl = mct_aVect_indexRA(a2x_o,'Faxa_rainl') + index_r2x_Forr_rofl = mct_aVect_indexRA(r2x_o,'Forr_rofl') + index_r2x_Forr_rofi = mct_aVect_indexRA(r2x_o,'Forr_rofi') + index_r2x_Flrr_flood = mct_aVect_indexRA(r2x_o,'Flrr_flood') + index_g2x_Fogg_rofl = mct_aVect_indexRA(g2x_o,'Fogg_rofl') + index_g2x_Fogg_rofi = mct_aVect_indexRA(g2x_o,'Fogg_rofi') + index_x2o_Faxa_snow = mct_aVect_indexRA(x2o_o,'Faxa_snow') + index_x2o_Faxa_rain = mct_aVect_indexRA(x2o_o,'Faxa_rain') + index_x2o_Faxa_prec = mct_aVect_indexRA(x2o_o,'Faxa_prec') + index_x2o_Foxx_rofl = mct_aVect_indexRA(x2o_o,'Foxx_rofl') + index_x2o_Foxx_rofi = mct_aVect_indexRA(x2o_o,'Foxx_rofi') + + if (seq_flds_i2o_per_cat) then + index_x2o_Sf_afrac = mct_aVect_indexRA(x2o_o,'Sf_afrac') + index_x2o_Sf_afracr = mct_aVect_indexRA(x2o_o,'Sf_afracr') + index_x2o_Foxx_swnet_afracr = mct_aVect_indexRA(x2o_o,'Foxx_swnet_afracr') + endif + + !wiso: + ! H2_16O + index_a2x_Faxa_snowc_16O = mct_aVect_indexRA(a2x_o,'Faxa_snowc_16O', perrWith='quiet') + index_a2x_Faxa_snowl_16O = mct_aVect_indexRA(a2x_o,'Faxa_snowl_16O', perrWith='quiet') + index_a2x_Faxa_rainc_16O = mct_aVect_indexRA(a2x_o,'Faxa_rainc_16O', perrWith='quiet') + index_a2x_Faxa_rainl_16O = mct_aVect_indexRA(a2x_o,'Faxa_rainl_16O', perrWith='quiet') + index_r2x_Forr_rofl_16O = mct_aVect_indexRA(r2x_o,'Forr_rofl_16O' , perrWith='quiet') + index_r2x_Forr_rofi_16O = mct_aVect_indexRA(r2x_o,'Forr_rofi_16O' , perrWith='quiet') + index_x2o_Faxa_rain_16O = mct_aVect_indexRA(x2o_o,'Faxa_rain_16O' , perrWith='quiet') + index_x2o_Faxa_snow_16O = mct_aVect_indexRA(x2o_o,'Faxa_snow_16O' , perrWith='quiet') + index_x2o_Faxa_prec_16O = mct_aVect_indexRA(x2o_o,'Faxa_prec_16O' , perrWith='quiet') + index_x2o_Foxx_rofl_16O = mct_aVect_indexRA(x2o_o,'Foxx_rofl_16O' , perrWith='quiet') + index_x2o_Foxx_rofi_16O = mct_aVect_indexRA(x2o_o,'Foxx_rofi_16O' , perrWith='quiet') + ! H2_18O + index_a2x_Faxa_snowc_18O = mct_aVect_indexRA(a2x_o,'Faxa_snowc_18O', perrWith='quiet') + index_a2x_Faxa_snowl_18O = mct_aVect_indexRA(a2x_o,'Faxa_snowl_18O', perrWith='quiet') + index_a2x_Faxa_rainc_18O = mct_aVect_indexRA(a2x_o,'Faxa_rainc_18O', perrWith='quiet') + index_a2x_Faxa_rainl_18O = mct_aVect_indexRA(a2x_o,'Faxa_rainl_18O', perrWith='quiet') + index_r2x_Forr_rofl_18O = mct_aVect_indexRA(r2x_o,'Forr_rofl_18O' , perrWith='quiet') + index_r2x_Forr_rofi_18O = mct_aVect_indexRA(r2x_o,'Forr_rofi_18O' , perrWith='quiet') + index_x2o_Faxa_rain_18O = mct_aVect_indexRA(x2o_o,'Faxa_rain_18O' , perrWith='quiet') + index_x2o_Faxa_snow_18O = mct_aVect_indexRA(x2o_o,'Faxa_snow_18O' , perrWith='quiet') + index_x2o_Faxa_prec_18O = mct_aVect_indexRA(x2o_o,'Faxa_prec_18O' , perrWith='quiet') + index_x2o_Foxx_rofl_18O = mct_aVect_indexRA(x2o_o,'Foxx_rofl_18O' , perrWith='quiet') + index_x2o_Foxx_rofi_18O = mct_aVect_indexRA(x2o_o,'Foxx_rofi_18O' , perrWith='quiet') + ! HDO + index_a2x_Faxa_snowc_HDO = mct_aVect_indexRA(a2x_o,'Faxa_snowc_HDO', perrWith='quiet') + index_a2x_Faxa_snowl_HDO = mct_aVect_indexRA(a2x_o,'Faxa_snowl_HDO', perrWith='quiet') + index_a2x_Faxa_rainc_HDO = mct_aVect_indexRA(a2x_o,'Faxa_rainc_HDO', perrWith='quiet') + index_a2x_Faxa_rainl_HDO = mct_aVect_indexRA(a2x_o,'Faxa_rainl_HDO', perrWith='quiet') + index_r2x_Forr_rofl_HDO = mct_aVect_indexRA(r2x_o,'Forr_rofl_HDO' , perrWith='quiet') + index_r2x_Forr_rofi_HDO = mct_aVect_indexRA(r2x_o,'Forr_rofi_HDO' , perrWith='quiet') + index_x2o_Faxa_rain_HDO = mct_aVect_indexRA(x2o_o,'Faxa_rain_HDO' , perrWith='quiet') + index_x2o_Faxa_snow_HDO = mct_aVect_indexRA(x2o_o,'Faxa_snow_HDO' , perrWith='quiet') + index_x2o_Faxa_prec_HDO = mct_aVect_indexRA(x2o_o,'Faxa_prec_HDO' , perrWith='quiet') + index_x2o_Foxx_rofl_HDO = mct_aVect_indexRA(x2o_o,'Foxx_rofl_HDO' , perrWith='quiet') + index_x2o_Foxx_rofi_HDO = mct_aVect_indexRA(x2o_o,'Foxx_rofi_HDO' , perrWith='quiet') + + ! Compute all other quantities based on standardized naming convention (see below) + ! Only ocn field states that have the name-prefix Sx_ will be merged + ! Only field names have the same name-suffix (after the "_") will be merged + ! (e.g. Si_fldname, Sa_fldname => merged to => Sx_fldname) + ! All fluxes will be scaled by the corresponding afrac or ifrac + ! EXCEPT for + ! -- Faxa_snnet, Faxa_snow, Faxa_rain, Faxa_prec (derived) + ! All i2x_o fluxes that have the name-suffix "Faii" (atm/ice fluxes) will be ignored + ! - only ice fluxes that are Fioi_... will be used in the ocean merges + + allocate(aindx(noflds), amerge(noflds)) + allocate(iindx(noflds), imerge(noflds)) + allocate(xindx(noflds), xmerge(noflds)) + allocate(field_atm(naflds), itemc_atm(naflds)) + allocate(field_ice(niflds), itemc_ice(niflds)) + allocate(field_ocn(noflds), itemc_ocn(noflds)) + allocate(field_rof(nrflds), itemc_rof(nrflds)) + allocate(field_wav(nwflds), itemc_wav(nwflds)) + allocate(field_xao(nxflds), itemc_xao(nxflds)) + allocate(mrgstr(noflds)) + aindx(:) = 0 + iindx(:) = 0 + xindx(:) = 0 + amerge(:) = .true. + imerge(:) = .true. + xmerge(:) = .true. + + do ko = 1,noflds + field_ocn(ko) = mct_aVect_getRList2c(ko, x2o_o) + itemc_ocn(ko) = trim(field_ocn(ko)(scan(field_ocn(ko),'_'):)) + enddo + do ka = 1,naflds + field_atm(ka) = mct_aVect_getRList2c(ka, a2x_o) + itemc_atm(ka) = trim(field_atm(ka)(scan(field_atm(ka),'_'):)) + enddo + do ki = 1,niflds + field_ice(ki) = mct_aVect_getRList2c(ki, i2x_o) + itemc_ice(ki) = trim(field_ice(ki)(scan(field_ice(ki),'_'):)) + enddo + do kr = 1,nrflds + field_rof(kr) = mct_aVect_getRList2c(kr, r2x_o) + itemc_rof(kr) = trim(field_rof(kr)(scan(field_rof(kr),'_'):)) + enddo + do kw = 1,nwflds + field_wav(kw) = mct_aVect_getRList2c(kw, w2x_o) + itemc_wav(kw) = trim(field_wav(kw)(scan(field_wav(kw),'_'):)) + enddo + do kx = 1,nxflds + field_xao(kx) = mct_aVect_getRList2c(kx, xao_o) + itemc_xao(kx) = trim(field_xao(kx)(scan(field_xao(kx),'_'):)) + enddo + + call mct_aVect_setSharedIndices(a2x_o, x2o_o, a2x_SharedIndices) + call mct_aVect_setSharedIndices(i2x_o, x2o_o, i2x_SharedIndices) + call mct_aVect_setSharedIndices(r2x_o, x2o_o, r2x_SharedIndices) + call mct_aVect_setSharedIndices(w2x_o, x2o_o, w2x_SharedIndices) + call mct_aVect_setSharedIndices(xao_o, x2o_o, xao_SharedIndices) + + do ko = 1,noflds + !--- document merge --- + mrgstr(ko) = subname//'x2o%'//trim(field_ocn(ko))//' =' + if (field_ocn(ko)(1:2) == 'PF') then + cycle ! if flux has first character as P, pass straight through + end if + if (field_ocn(ko)(1:1) == 'S' .and. field_ocn(ko)(2:2) /= 'x') then + cycle ! ignore all ocn states that do not have a Sx_ prefix + end if + if (trim(field_ocn(ko)) == 'Foxx_swnet' .or. & + trim(field_ocn(ko)) == 'Faxa_snow' .or. & + trim(field_ocn(ko)) == 'Faxa_rain' .or. & + trim(field_ocn(ko)) == 'Faxa_prec' )then + cycle ! ignore swnet, snow, rain, prec - treated explicitly above + end if + if (index(field_ocn(ko), 'Faxa_snow_' ) == 1 .or. & + index(field_ocn(ko), 'Faxa_rain_' ) == 1 .or. & + index(field_ocn(ko), 'Faxa_prec_' ) == 1 )then + cycle ! ignore isotope snow, rain, prec - treated explicitly above + end if +! if (trim(field_ocn(ko)(1:5)) == 'Foxx_') then +! cycle ! ignore runoff fields from land - treated in coupler +! end if + + do ka = 1,naflds + if (trim(itemc_ocn(ko)) == trim(itemc_atm(ka))) then + if ((trim(field_ocn(ko)) == trim(field_atm(ka)))) then + if (field_atm(ka)(1:1) == 'F') amerge(ko) = .false. + end if + ! --- make sure only one field matches --- + if (aindx(ko) /= 0) then + write(logunit,*) subname,' ERROR: found multiple ka field matches for ',trim(itemc_atm(ka)) + call shr_sys_abort(subname//' ERROR multiple ka field matches') + endif + aindx(ko) = ka + end if + end do + do ki = 1,niflds + if (field_ice(ki)(1:1) == 'F' .and. field_ice(ki)(2:4) == 'aii') then + cycle ! ignore all i2x_o fluxes that are ice/atm fluxes + end if + if (trim(itemc_ocn(ko)) == trim(itemc_ice(ki))) then + if ((trim(field_ocn(ko)) == trim(field_ice(ki)))) then + if (field_ice(ki)(1:1) == 'F') imerge(ko) = .false. + end if + ! --- make sure only one field matches --- + if (iindx(ko) /= 0) then + write(logunit,*) subname,' ERROR: found multiple ki field matches for ',trim(itemc_ice(ki)) + call shr_sys_abort(subname//' ERROR multiple ki field matches') + endif + iindx(ko) = ki + end if + end do + do kx = 1,nxflds + if (trim(itemc_ocn(ko)) == trim(itemc_xao(kx))) then + if ((trim(field_ocn(ko)) == trim(field_xao(kx)))) then + if (field_xao(kx)(1:1) == 'F') xmerge(ko) = .false. + end if + ! --- make sure only one field matches --- + if (xindx(ko) /= 0) then + write(logunit,*) subname,' ERROR: found multiple kx field matches for ',trim(itemc_xao(kx)) + call shr_sys_abort(subname//' ERROR multiple kx field matches') + endif + xindx(ko) = kx + end if + end do + + ! --- add some checks --- + + ! --- make sure no merge of BOTH atm and xao --- + if (aindx(ko) > 0 .and. xindx(ko) > 0) then + write(logunit,*) subname,' ERROR: aindx and xindx both non-zero, not allowed' + call shr_sys_abort(subname//' ERROR aindx and xindx both non-zero') + endif + + ! --- make sure all terms agree on merge or non-merge aspect --- + if (aindx(ko) > 0 .and. iindx(ko) > 0 .and. (amerge(ko) .neqv. imerge(ko))) then + write(logunit,*) subname,' ERROR: aindx and iindx merge logic error' + call shr_sys_abort(subname//' ERROR aindx and iindx merge logic error') + endif + if (aindx(ko) > 0 .and. xindx(ko) > 0 .and. (amerge(ko) .neqv. xmerge(ko))) then + write(logunit,*) subname,' ERROR: aindx and xindx merge logic error' + call shr_sys_abort(subname//' ERROR aindx and xindx merge logic error') + endif + if (xindx(ko) > 0 .and. iindx(ko) > 0 .and. (xmerge(ko) .neqv. imerge(ko))) then + write(logunit,*) subname,' ERROR: xindx and iindx merge logic error' + call shr_sys_abort(subname//' ERROR xindx and iindx merge logic error') + endif + + end do + + end if + + call mct_aVect_zero(x2o_o) + + !--- document copy operations --- + if (first_time) then + !--- document merge --- + do i=1,a2x_SharedIndices%shared_real%num_indices + i1=a2x_SharedIndices%shared_real%aVindices1(i) + o1=a2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = a2x%'//trim(field_atm(i1)) + enddo + do i=1,i2x_SharedIndices%shared_real%num_indices + i1=i2x_SharedIndices%shared_real%aVindices1(i) + o1=i2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = i2x%'//trim(field_ice(i1)) + enddo + do i=1,r2x_SharedIndices%shared_real%num_indices + i1=r2x_SharedIndices%shared_real%aVindices1(i) + o1=r2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = r2x%'//trim(field_rof(i1)) + enddo + do i=1,w2x_SharedIndices%shared_real%num_indices + i1=w2x_SharedIndices%shared_real%aVindices1(i) + o1=w2x_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = w2x%'//trim(field_wav(i1)) + enddo + do i=1,xao_SharedIndices%shared_real%num_indices + i1=xao_SharedIndices%shared_real%aVindices1(i) + o1=xao_SharedIndices%shared_real%aVindices2(i) + mrgstr(o1) = trim(mrgstr(o1))//' = xao%'//trim(field_xao(i1)) + enddo + endif + +! call mct_aVect_copy(aVin=a2x_o, aVout=x2o_o, vector=mct_usevector) +! call mct_aVect_copy(aVin=i2x_o, aVout=x2o_o, vector=mct_usevector) +! call mct_aVect_copy(aVin=r2x_o, aVout=x2o_o, vector=mct_usevector) +! call mct_aVect_copy(aVin=w2x_o, aVout=x2o_o, vector=mct_usevector) +! call mct_aVect_copy(aVin=xao_o, aVout=x2o_o, vector=mct_usevector) + call mct_aVect_copy(aVin=a2x_o, aVout=x2o_o, vector=mct_usevector, sharedIndices=a2x_SharedIndices) + call mct_aVect_copy(aVin=i2x_o, aVout=x2o_o, vector=mct_usevector, sharedIndices=i2x_SharedIndices) + call mct_aVect_copy(aVin=r2x_o, aVout=x2o_o, vector=mct_usevector, sharedIndices=r2x_SharedIndices) + call mct_aVect_copy(aVin=w2x_o, aVout=x2o_o, vector=mct_usevector, sharedIndices=w2x_SharedIndices) + call mct_aVect_copy(aVin=xao_o, aVout=x2o_o, vector=mct_usevector, sharedIndices=xao_SharedIndices) + + !--- document manual merges --- + if (first_time) then + mrgstr(index_x2o_Foxx_swnet) = trim(mrgstr(index_x2o_Foxx_swnet))//' = '// & + 'afracr*(a2x%Faxa_swvdr*(1.0-xao%So_avsdr) + '// & + 'a2x%Faxa_swvdf*(1.0-xao%So_avsdf) + '// & + 'a2x%Faxa_swndr*(1.0-xao%So_anidr) + '// & + 'a2x%Faxa_swndf*(1.0-xao%So_anidf)) + '// & + 'ifrac*i2x%Fioi_swpen' + if (seq_flds_i2o_per_cat) then + mrgstr(index_x2o_Foxx_swnet_afracr) = trim(mrgstr(index_x2o_Foxx_swnet_afracr))//' = '// & + 'afracr*(a2x%Faxa_swvdr*(1.0-xao%So_avsdr) + '// & + 'a2x%Faxa_swvdf*(1.0-xao%So_avsdf) + '// & + 'a2x%Faxa_swndr*(1.0-xao%So_anidr) + '// & + 'a2x%Faxa_swndf*(1.0-xao%So_anidf))' + end if + mrgstr(index_x2o_Faxa_snow) = trim(mrgstr(index_x2o_Faxa_snow))//' = '// & + 'afrac*(a2x%Faxa_snowc + a2x%Faxa_snowl)*flux_epbalfact' + mrgstr(index_x2o_Faxa_rain) = trim(mrgstr(index_x2o_Faxa_rain))//' = '// & + 'afrac*(a2x%Faxa_rainc + a2x%Faxa_rainl)*flux_epbalfact' + mrgstr(index_x2o_Faxa_prec) = trim(mrgstr(index_x2o_Faxa_prec))//' = '// & + 'afrac*(a2x%Faxa_snowc + a2x%Faxa_snowl + a2x%Faxa_rainc + a2x%Faxa_rainl)*flux_epbalfact' + mrgstr(index_x2o_Foxx_rofl) = trim(mrgstr(index_x2o_Foxx_rofl))//' = '// & + '(r2x%Forr_rofl + r2x%Flrr_flood + g2x%Fogg_rofl)*flux_epbalfact' + mrgstr(index_x2o_Foxx_rofi) = trim(mrgstr(index_x2o_Foxx_rofi))//' = '// & + '(r2x%Forr_rofi + g2x%Fogg_rofi)*flux_epbalfact' + ! water isotope snow, rain prec + if ( index_x2o_Faxa_snow_16O /= 0 )then + mrgstr(index_x2o_Faxa_snow_16O) = trim(mrgstr(index_x2o_Faxa_snow_16O))//' = '// & + 'afrac*(a2x%Faxa_snowc_16O + a2x%Faxa_snowl_16O)*flux_epbalfact' + mrgstr(index_x2o_Faxa_rain_16O) = trim(mrgstr(index_x2o_Faxa_rain_16O))//' = '// & + 'afrac*(a2x%Faxa_rainc_16O + a2x%Faxa_rainl_16O)*flux_epbalfact' + mrgstr(index_x2o_Faxa_prec_16O) = trim(mrgstr(index_x2o_Faxa_prec_16O))//' = '// & + 'afrac*(a2x%Faxa_snowc_16O + a2x%Faxa_snowl_16O + a2x%Faxa_rainc_16O + '// & + 'a2x%Faxa_rainl_16O)*flux_epbalfact' + end if + if ( index_x2o_Faxa_snow_18O /= 0 )then + mrgstr(index_x2o_Faxa_snow_18O) = trim(mrgstr(index_x2o_Faxa_snow_18O))//' = '// & + 'afrac*(a2x%Faxa_snowc_18O + a2x%Faxa_snowl_18O)*flux_epbalfact' + mrgstr(index_x2o_Faxa_rain_18O) = trim(mrgstr(index_x2o_Faxa_rain_18O))//' = '// & + 'afrac*(a2x%Faxa_rainc_18O + a2x%Faxa_rainl_18O)*flux_epbalfact' + mrgstr(index_x2o_Faxa_prec_18O) = trim(mrgstr(index_x2o_Faxa_prec_18O))//' = '// & + 'afrac*(a2x%Faxa_snowc_18O + a2x%Faxa_snowl_18O + a2x%Faxa_rainc_18O + '// & + 'a2x%Faxa_rainl_18O)*flux_epbalfact' + end if + if ( index_x2o_Faxa_snow_HDO /= 0 )then + mrgstr(index_x2o_Faxa_snow_HDO) = trim(mrgstr(index_x2o_Faxa_snow_HDO))//' = '// & + 'afrac*(a2x%Faxa_snowc_HDO + a2x%Faxa_snowl_HDO)*flux_epbalfact' + mrgstr(index_x2o_Faxa_rain_HDO) = trim(mrgstr(index_x2o_Faxa_rain_HDO))//' = '// & + 'afrac*(a2x%Faxa_rainc_HDO + a2x%Faxa_rainl_HDO)*flux_epbalfact' + mrgstr(index_x2o_Faxa_prec_HDO) = trim(mrgstr(index_x2o_Faxa_prec_HDO))//' = '// & + 'afrac*(a2x%Faxa_snowc_HDO + a2x%Faxa_snowl_HDO + a2x%Faxa_rainc_HDO + '// & + 'a2x%Faxa_rainl_HDO)*flux_epbalfact' + end if + endif + + ! Compute input ocn state (note that this only applies to non-land portion of gridcell) + + kif = mct_aVect_indexRa(fractions_o,"ifrac",perrWith=subName) + kof = mct_aVect_indexRa(fractions_o,"ofrac",perrWith=subName) + kir = mct_aVect_indexRa(fractions_o,"ifrad",perrWith=subName) + kor = mct_aVect_indexRa(fractions_o,"ofrad",perrWith=subName) + lsize = mct_aVect_lsize(x2o_o) + do n = 1,lsize + + ifrac = fractions_o%rAttr(kif,n) + afrac = fractions_o%rAttr(kof,n) + frac_sum = ifrac + afrac + if ((frac_sum) /= 0._r8) then + ifrac = ifrac / (frac_sum) + afrac = afrac / (frac_sum) + endif + + ifracr = fractions_o%rAttr(kir,n) + afracr = fractions_o%rAttr(kor,n) + frac_sum = ifracr + afracr + if ((frac_sum) /= 0._r8) then + ifracr = ifracr / (frac_sum) + afracr = afracr / (frac_sum) + endif + + ! Derived: compute net short-wave + avsdr = xao_o%rAttr(index_xao_So_avsdr,n) + anidr = xao_o%rAttr(index_xao_So_anidr,n) + avsdf = xao_o%rAttr(index_xao_So_avsdf,n) + anidf = xao_o%rAttr(index_xao_So_anidf,n) + fswabsv = a2x_o%rAttr(index_a2x_Faxa_swvdr,n) * (1.0_R8 - avsdr) & + + a2x_o%rAttr(index_a2x_Faxa_swvdf,n) * (1.0_R8 - avsdf) + fswabsi = a2x_o%rAttr(index_a2x_Faxa_swndr,n) * (1.0_R8 - anidr) & + + a2x_o%rAttr(index_a2x_Faxa_swndf,n) * (1.0_R8 - anidf) + x2o_o%rAttr(index_x2o_Foxx_swnet,n) = (fswabsv + fswabsi) * afracr + & + i2x_o%rAttr(index_i2x_Fioi_swpen,n) * ifrac + + if (seq_flds_i2o_per_cat) then + x2o_o%rAttr(index_x2o_Sf_afrac,n) = afrac + x2o_o%rAttr(index_x2o_Sf_afracr,n) = afracr + x2o_o%rAttr(index_x2o_Foxx_swnet_afracr,n) = (fswabsv + fswabsi) * afracr + end if + + ! Derived: compute total precipitation - scale total precip and runoff + + x2o_o%rAttr(index_x2o_Faxa_snow ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow ,n) = x2o_o%rAttr(index_x2o_Faxa_snow ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain ,n) = x2o_o%rAttr(index_x2o_Faxa_rain ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec ,n) = x2o_o%rAttr(index_x2o_Faxa_rain ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow ,n) + + x2o_o%rAttr(index_x2o_Foxx_rofl, n) = (r2x_o%rAttr(index_r2x_Forr_rofl , n) + & + r2x_o%rAttr(index_r2x_Flrr_flood, n) + & + g2x_o%rAttr(index_g2x_Fogg_rofl , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofi, n) = (r2x_o%rAttr(index_r2x_Forr_rofi , n) + & + g2x_o%rAttr(index_g2x_Fogg_rofi , n)) * flux_epbalfact + + + if ( index_x2o_Foxx_rofl_16O /= 0 ) then + x2o_o%rAttr(index_x2o_Foxx_rofl_16O, n) = (r2x_o%rAttr(index_r2x_Forr_rofl_16O, n) + & + r2x_o%rAttr(index_r2x_Flrr_flood, n) + & + g2x_o%rAttr(index_g2x_Fogg_rofl , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofi_16O, n) = (r2x_o%rAttr(index_r2x_Forr_rofi_16O , n) + & + g2x_o%rAttr(index_g2x_Fogg_rofi , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofl_18O, n) = (r2x_o%rAttr(index_r2x_Forr_rofl_18O, n) + & + r2x_o%rAttr(index_r2x_Flrr_flood, n) + & + g2x_o%rAttr(index_g2x_Fogg_rofl , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofi_18O, n) = (r2x_o%rAttr(index_r2x_Forr_rofi_18O , n) + & + g2x_o%rAttr(index_g2x_Fogg_rofi , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofl_HDO, n) = (r2x_o%rAttr(index_r2x_Forr_rofl_HDO, n) + & + r2x_o%rAttr(index_r2x_Flrr_flood, n) + & + g2x_o%rAttr(index_g2x_Fogg_rofl , n)) * flux_epbalfact + x2o_o%rAttr(index_x2o_Foxx_rofi_HDO, n) = (r2x_o%rAttr(index_r2x_Forr_rofi_HDO , n) + & + g2x_o%rAttr(index_g2x_Fogg_rofi , n)) * flux_epbalfact + end if + + ! Derived: water isotopes total preciptiation and scaling + + if ( index_x2o_Faxa_snow_16O /= 0 )then + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_16O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_16O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_16O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_16O,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec_16O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_16O ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_16O ,n) + end if + + if ( index_x2o_Faxa_snow_18O /= 0 )then + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_18O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_18O,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_18O,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_18O,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec_18O ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_18O ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_18O ,n) + end if + + if ( index_x2o_Faxa_snow_HDO /= 0 )then + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc_HDO,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_snowl_HDO,n) * afrac + x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc_HDO,n) * afrac + & + a2x_o%rAttr(index_a2x_Faxa_rainl_HDO,n) * afrac + + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) * flux_epbalfact + x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) * flux_epbalfact + + x2o_o%rAttr(index_x2o_Faxa_prec_HDO ,n) = x2o_o%rAttr(index_x2o_Faxa_rain_HDO ,n) + & + x2o_o%rAttr(index_x2o_Faxa_snow_HDO ,n) + end if + end do + + do ko = 1,noflds + !--- document merge --- + if (first_time) then + if (iindx(ko) > 0) then + if (imerge(ko)) then + mrgstr(ko) = trim(mrgstr(ko))//' + ifrac*i2x%'//trim(field_ice(iindx(ko))) + else + mrgstr(ko) = trim(mrgstr(ko))//' = ifrac*i2x%'//trim(field_ice(iindx(ko))) + end if + end if + if (aindx(ko) > 0) then + if (amerge(ko)) then + mrgstr(ko) = trim(mrgstr(ko))//' + afrac*a2x%'//trim(field_atm(aindx(ko))) + else + mrgstr(ko) = trim(mrgstr(ko))//' = afrac*a2x%'//trim(field_atm(aindx(ko))) + end if + end if + if (xindx(ko) > 0) then + if (xmerge(ko)) then + mrgstr(ko) = trim(mrgstr(ko))//' + afrac*xao%'//trim(field_xao(xindx(ko))) + else + mrgstr(ko) = trim(mrgstr(ko))//' = afrac*xao%'//trim(field_xao(xindx(ko))) + end if + end if + endif + + do n = 1,lsize + ifrac = fractions_o%rAttr(kif,n) + afrac = fractions_o%rAttr(kof,n) + frac_sum = ifrac + afrac + if ((frac_sum) /= 0._r8) then + ifrac = ifrac / (frac_sum) + afrac = afrac / (frac_sum) + endif + if (iindx(ko) > 0) then + if (imerge(ko)) then + x2o_o%rAttr(ko,n) = x2o_o%rAttr(ko,n) + i2x_o%rAttr(iindx(ko),n) * ifrac + else + x2o_o%rAttr(ko,n) = i2x_o%rAttr(iindx(ko),n) * ifrac + end if + end if + if (aindx(ko) > 0) then + if (amerge(ko)) then + x2o_o%rAttr(ko,n) = x2o_o%rAttr(ko,n) + a2x_o%rAttr(aindx(ko),n) * afrac + else + x2o_o%rAttr(ko,n) = a2x_o%rAttr(aindx(ko),n) * afrac + end if + end if + if (xindx(ko) > 0) then + if (xmerge(ko)) then + x2o_o%rAttr(ko,n) = x2o_o%rAttr(ko,n) + xao_o%rAttr(xindx(ko),n) * afrac + else + x2o_o%rAttr(ko,n) = xao_o%rAttr(xindx(ko),n) * afrac + end if + end if + end do + end do + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do ko = 1,noflds + write(logunit,'(A)') trim(mrgstr(ko)) + enddo + endif + deallocate(mrgstr) + deallocate(field_atm,itemc_atm) + deallocate(field_ocn,itemc_ocn) + deallocate(field_ice,itemc_ice) + deallocate(field_rof,itemc_rof) + deallocate(field_wav,itemc_wav) + deallocate(field_xao,itemc_xao) + endif + + first_time = .false. + + end subroutine prep_ocn_merge + + !================================================================================================ + + subroutine prep_ocn_calc_a2x_ox(timer) + !--------------------------------------------------------------- + ! + ! Arguments + character(len=*) , intent(in) :: timer + ! + ! Local Variables + integer :: eai + type(mct_avect), pointer :: a2x_ax + character(*), parameter :: subname = '(prep_ocn_calc_a2x_ox)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eai = 1,num_inst_atm + a2x_ax => component_get_c2x_cx(atm(eai)) + + call seq_map_map(mapper_Sa2o, a2x_ax, a2x_ox(eai), fldlist=seq_flds_a2x_states, norm=.true.) + + call seq_map_map(mapper_Fa2o, a2x_ax, a2x_ox(eai), fldlist=seq_flds_a2x_fluxes, norm=.true.) + + !--- tcx the norm should be true below, it's false for bfb backwards compatability + call seq_map_mapvect(mapper_Va2o, vect_map, a2x_ax, a2x_ox(eai), 'Sa_u', 'Sa_v', norm=.false.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ocn_calc_a2x_ox + + !================================================================================================ + + subroutine prep_ocn_calc_i2x_ox(timer) + !--------------------------------------------------------------- + ! Description + ! Create g2x_ox (note that i2x_ox is a local module variable) + ! + ! Arguments + character(len=*) , intent(in) :: timer + ! + ! Local Variables + integer :: eii + type(mct_avect), pointer :: i2x_ix + character(*), parameter :: subname = '(prep_ocn_calc_i2x_ox)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eii = 1,num_inst_ice + i2x_ix => component_get_c2x_cx(ice(eii)) + call seq_map_map(mapper_SFi2o, i2x_ix, i2x_ox(eii), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ocn_calc_i2x_ox + + !================================================================================================ + + subroutine prep_ocn_calc_r2x_ox(timer) + !--------------------------------------------------------------- + ! Description + ! Create r2x_ox (note that r2x_ox is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eri + type(mct_avect), pointer :: r2x_rx + character(*), parameter :: subname = '(prep_ocn_calc_r2x_ox)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + r2x_rx => component_get_c2x_cx(rof(eri)) + call seq_map_map(mapper_Rr2o_liq, r2x_rx, r2x_ox(eri), & + fldlist=seq_flds_r2o_liq_fluxes, norm=.false.) + + call seq_map_map(mapper_Rr2o_ice, r2x_rx, r2x_ox(eri), & + fldlist=seq_flds_r2o_ice_fluxes, norm=.false.) + + if (flood_present) then + call seq_map_map(mapper_Fr2o, r2x_rx, r2x_ox(eri), & + fldlist='Flrr_flood', norm=.true.) + endif + enddo + call t_drvstopf (trim(timer)) + + end subroutine prep_ocn_calc_r2x_ox + + !================================================================================================ + + subroutine prep_ocn_calc_g2x_ox(timer) + !--------------------------------------------------------------- + ! Description + ! Create g2x_ox (note that g2x_ox is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: egi + type(mct_avect), pointer :: g2x_gx + character(*), parameter :: subname = '(prep_ocn_calc_g2x_ox)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do egi = 1,num_inst_glc + g2x_gx => component_get_c2x_cx(glc(egi)) + call seq_map_map(mapper_Rg2o, g2x_gx, g2x_ox(egi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + end subroutine prep_ocn_calc_g2x_ox + + !================================================================================================ + + subroutine prep_ocn_calc_w2x_ox(timer) + !--------------------------------------------------------------- + ! Description + ! Create w2x_ox (note that w2x_ox is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: ewi + type(mct_avect), pointer :: w2x_wx + character(*), parameter :: subname = '(prep_ocn_calc_w2x_ox)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do ewi = 1,num_inst_wav + w2x_wx => component_get_c2x_cx(wav(ewi)) + call seq_map_map(mapper_Sw2o, w2x_wx, w2x_ox(ewi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + end subroutine prep_ocn_calc_w2x_ox + + !================================================================================================ + + function prep_ocn_get_a2x_ox() + type(mct_aVect), pointer :: prep_ocn_get_a2x_ox(:) + prep_ocn_get_a2x_ox => a2x_ox(:) + end function prep_ocn_get_a2x_ox + + function prep_ocn_get_r2x_ox() + type(mct_aVect), pointer :: prep_ocn_get_r2x_ox(:) + prep_ocn_get_r2x_ox => r2x_ox(:) + end function prep_ocn_get_r2x_ox + + function prep_ocn_get_i2x_ox() + type(mct_aVect), pointer :: prep_ocn_get_i2x_ox(:) + prep_ocn_get_i2x_ox => i2x_ox(:) + end function prep_ocn_get_i2x_ox + + function prep_ocn_get_g2x_ox() + type(mct_aVect), pointer :: prep_ocn_get_g2x_ox(:) + prep_ocn_get_g2x_ox => g2x_ox(:) + end function prep_ocn_get_g2x_ox + + function prep_ocn_get_w2x_ox() + type(mct_aVect), pointer :: prep_ocn_get_w2x_ox(:) + prep_ocn_get_w2x_ox => w2x_ox(:) + end function prep_ocn_get_w2x_ox + + function prep_ocn_get_x2oacc_ox() + type(mct_aVect), pointer :: prep_ocn_get_x2oacc_ox(:) + prep_ocn_get_x2oacc_ox => x2oacc_ox(:) + end function prep_ocn_get_x2oacc_ox + + function prep_ocn_get_x2oacc_ox_cnt() + integer, pointer :: prep_ocn_get_x2oacc_ox_cnt + prep_ocn_get_x2oacc_ox_cnt => x2oacc_ox_cnt + end function prep_ocn_get_x2oacc_ox_cnt + + function prep_ocn_get_mapper_Sa2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Sa2o + prep_ocn_get_mapper_Sa2o => mapper_Sa2o + end function prep_ocn_get_mapper_Sa2o + + function prep_ocn_get_mapper_Va2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Va2o + prep_ocn_get_mapper_Va2o => mapper_Va2o + end function prep_ocn_get_mapper_Va2o + + function prep_ocn_get_mapper_Fa2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Fa2o + prep_ocn_get_mapper_Fa2o => mapper_Fa2o + end function prep_ocn_get_mapper_Fa2o + + function prep_ocn_get_mapper_Fr2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Fr2o + prep_ocn_get_mapper_Fr2o => mapper_Fr2o + end function prep_ocn_get_mapper_Fr2o + + function prep_ocn_get_mapper_Rr2o_liq() + type(seq_map), pointer :: prep_ocn_get_mapper_Rr2o_liq + prep_ocn_get_mapper_Rr2o_liq => mapper_Rr2o_liq + end function prep_ocn_get_mapper_Rr2o_liq + + function prep_ocn_get_mapper_Rr2o_ice() + type(seq_map), pointer :: prep_ocn_get_mapper_Rr2o_ice + prep_ocn_get_mapper_Rr2o_ice => mapper_Rr2o_ice + end function prep_ocn_get_mapper_Rr2o_ice + + function prep_ocn_get_mapper_SFi2o() + type(seq_map), pointer :: prep_ocn_get_mapper_SFi2o + prep_ocn_get_mapper_SFi2o => mapper_SFi2o + end function prep_ocn_get_mapper_SFi2o + + function prep_ocn_get_mapper_Rg2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Rg2o + prep_ocn_get_mapper_Rg2o => mapper_Rg2o + end function prep_ocn_get_mapper_Rg2o + + function prep_ocn_get_mapper_Sw2o() + type(seq_map), pointer :: prep_ocn_get_mapper_Sw2o + prep_ocn_get_mapper_Sw2o => mapper_Sw2o + end function prep_ocn_get_mapper_Sw2o + +end module prep_ocn_mod diff --git a/driver-mct/main/prep_rof_mod.F90 b/driver-mct/main/prep_rof_mod.F90 new file mode 100644 index 000000000000..cc7fd6d46762 --- /dev/null +++ b/driver-mct/main/prep_rof_mod.F90 @@ -0,0 +1,499 @@ +module prep_rof_mod + +#include "shr_assert.h" + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_kind_mod, only: cs => SHR_KIND_CS + use shr_kind_mod, only: cl => SHR_KIND_CL + use shr_kind_mod, only: cxx => SHR_KIND_CXX + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use seq_comm_mct, only: num_inst_lnd, num_inst_rof, num_inst_frc + use seq_comm_mct, only: CPLID, ROFID, logunit + use seq_comm_mct, only: seq_comm_getData=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getdata + use shr_log_mod , only: errMsg => shr_log_errMsg + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: rof, lnd + use prep_lnd_mod, only: prep_lnd_get_mapper_Fr2l + use map_lnd2rof_irrig_mod, only: map_lnd2rof_irrig + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_rof_init + public :: prep_rof_mrg + + public :: prep_rof_accum + public :: prep_rof_accum_avg + + public :: prep_rof_calc_l2r_rx + + public :: prep_rof_get_l2racc_lx + public :: prep_rof_get_l2racc_lx_cnt + public :: prep_rof_get_mapper_Fl2r + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_rof_merge + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_Fl2r + + ! attribute vectors + type(mct_aVect), pointer :: l2r_rx(:) + + ! accumulation variables + type(mct_aVect), pointer :: l2racc_lx(:) ! lnd export, lnd grid, cpl pes + integer , target :: l2racc_lx_cnt ! l2racc_lx: number of time samples accumulated + + ! other module variables + integer :: mpicom_CPLID ! MPI cpl communicator + + ! field names and lists, for fields that need to be treated specially + character(len=*), parameter :: irrig_flux_field = 'Flrl_irrig' + ! fluxes mapped from lnd to rof that don't need any special handling + character(CXX) :: lnd2rof_normal_fluxes + ! whether the model is being run with a separate irrigation field + logical :: have_irrig_field + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_rof_init(infodata, lnd_c2_rof) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and all other non-mapping + ! module variables + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in) :: lnd_c2_rof ! .true. => lnd to rof coupling on + ! + ! Local Variables + integer :: lsize_r + integer :: lsize_l + integer :: eli, eri + logical :: samegrid_lr ! samegrid land and rof + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: rof_present ! .true. => rof is present + logical :: lnd_present ! .true. => lnd is present + logical :: iamroot_CPLID ! .true. => CPLID masterproc + character(CL) :: lnd_gnam ! lnd grid + character(CL) :: rof_gnam ! rof grid + type(mct_aVect) , pointer :: l2x_lx + type(mct_aVect) , pointer :: x2r_rx + integer :: index_irrig + character(*) , parameter :: subname = '(prep_rof_init)' + character(*) , parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata , & + esmf_map_flag=esmf_map_flag , & + rof_present=rof_present , & + lnd_present=lnd_present , & + lnd_gnam=lnd_gnam , & + rof_gnam=rof_gnam ) + + allocate(mapper_Fl2r) + + if (rof_present) then + x2r_rx => component_get_x2c_cx(rof(1)) + index_irrig = mct_aVect_indexRA(x2r_rx, irrig_flux_field, perrWith='quiet') + if (index_irrig == 0) then + have_irrig_field = .false. + else + have_irrig_field = .true. + end if + else + ! If rof_present is false, have_irrig_field should be irrelevant; we arbitrarily + ! set it to false in this case. + have_irrig_field = .false. + end if + + if (rof_present .and. lnd_present) then + + call seq_comm_getData(CPLID, & + mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + lsize_r = mct_aVect_lsize(x2r_rx) + + l2x_lx => component_get_c2x_cx(lnd(1)) + lsize_l = mct_aVect_lsize(l2x_lx) + + allocate(l2racc_lx(num_inst_lnd)) + do eli = 1,num_inst_lnd + call mct_aVect_initSharedFields(l2x_lx, x2r_rx, l2racc_lx(eli), lsize=lsize_l) + call mct_aVect_zero(l2racc_lx(eli)) + end do + l2racc_lx_cnt = 0 + + allocate(l2r_rx(num_inst_rof)) + do eri = 1,num_inst_rof + call mct_avect_init(l2r_rx(eri), rList=seq_flds_x2r_fields, lsize=lsize_r) + call mct_avect_zero(l2r_rx(eri)) + end do + + samegrid_lr = .true. + if (trim(lnd_gnam) /= trim(rof_gnam)) samegrid_lr = .false. + + if (lnd_c2_rof) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Fl2r' + end if + call seq_map_init_rcfile(mapper_Fl2r, lnd(1), rof(1), & + 'seq_maps.rc','lnd2rof_fmapname:','lnd2rof_fmaptype:',samegrid_lr, & + string='mapper_Fl2r initialization', esmf_map=esmf_map_flag) + + ! We'll map irrigation specially, so exclude this from the list of l2r fields + ! that are mapped "normally". Note that the following assumes that all + ! x2r_fluxes are lnd2rof (as opposed to coming from some other component). + ! + ! (This listDiff works even if have_irrig_field is false.) + call shr_string_listDiff( & + list1 = seq_flds_x2r_fluxes, & + list2 = irrig_flux_field, & + listout = lnd2rof_normal_fluxes) + endif + call shr_sys_flush(logunit) + + end if + + end subroutine prep_rof_init + + !================================================================================================ + + subroutine prep_rof_accum(timer) + + !--------------------------------------------------------------- + ! Description + ! Accumulate land input to river component + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eli + type(mct_aVect), pointer :: l2x_lx + character(*), parameter :: subname = '(prep_rof_accum)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eli = 1,num_inst_lnd + l2x_lx => component_get_c2x_cx(lnd(eli)) + if (l2racc_lx_cnt == 0) then + call mct_avect_copy(l2x_lx, l2racc_lx(eli)) + else + call mct_avect_accum(l2x_lx, l2racc_lx(eli)) + endif + end do + l2racc_lx_cnt = l2racc_lx_cnt + 1 + call t_drvstopf (trim(timer)) + + end subroutine prep_rof_accum + + !================================================================================================ + + subroutine prep_rof_accum_avg(timer) + + !--------------------------------------------------------------- + ! Description + ! Finalize accumulation of land input to river component + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eri, eli + character(*), parameter :: subname = '(prep_rof_accum_avg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + eli = mod((eri-1),num_inst_lnd) + 1 + call mct_avect_avg(l2racc_lx(eli),l2racc_lx_cnt) + end do + l2racc_lx_cnt = 0 + call t_drvstopf (trim(timer)) + + end subroutine prep_rof_accum_avg + + !================================================================================================ + + subroutine prep_rof_mrg(infodata, fractions_rx, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Merge rof inputs + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type(mct_aVect) , intent(in) :: fractions_rx(:) + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eri, efi + type(mct_aVect), pointer :: x2r_rx + character(*), parameter :: subname = '(prep_rof_mrg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_mrg), barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + efi = mod((eri-1),num_inst_frc) + 1 + + x2r_rx => component_get_x2c_cx(rof(eri)) ! This is actually modifying x2r_rx + call prep_rof_merge(l2r_rx(eri), fractions_rx(efi), x2r_rx) + end do + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_rof_mrg + + !================================================================================================ + + subroutine prep_rof_merge(l2x_r, fractions_r, x2r_r) + + !----------------------------------------------------------------------- + ! Description + ! Merge land rof and ice forcing for rof input + ! + ! Arguments + type(mct_aVect),intent(in) :: l2x_r + type(mct_aVect),intent(in) :: fractions_r + type(mct_aVect),intent(inout) :: x2r_r + ! + ! Local variables + integer :: i + integer, save :: index_l2x_Flrl_rofsur + integer, save :: index_l2x_Flrl_rofgwl + integer, save :: index_l2x_Flrl_rofsub + integer, save :: index_l2x_Flrl_rofdto + integer, save :: index_l2x_Flrl_rofi + integer, save :: index_l2x_Flrl_irrig + integer, save :: index_x2r_Flrl_rofsur + integer, save :: index_x2r_Flrl_rofgwl + integer, save :: index_x2r_Flrl_rofsub + integer, save :: index_x2r_Flrl_rofdto + integer, save :: index_x2r_Flrl_rofi + integer, save :: index_x2r_Flrl_irrig + integer, save :: index_l2x_Flrl_rofl_16O + integer, save :: index_l2x_Flrl_rofi_16O + integer, save :: index_x2r_Flrl_rofl_16O + integer, save :: index_x2r_Flrl_rofi_16O + integer, save :: index_l2x_Flrl_rofl_18O + integer, save :: index_l2x_Flrl_rofi_18O + integer, save :: index_x2r_Flrl_rofl_18O + integer, save :: index_x2r_Flrl_rofi_18O + integer, save :: index_l2x_Flrl_rofl_HDO + integer, save :: index_l2x_Flrl_rofi_HDO + integer, save :: index_x2r_Flrl_rofl_HDO + integer, save :: index_x2r_Flrl_rofi_HDO + integer, save :: index_lfrac + logical, save :: first_time = .true. + logical, save :: flds_wiso_rof = .false. + real(r8) :: lfrac + integer :: nflds,lsize + logical :: iamroot + character(CL) :: field ! field string + character(CL),allocatable :: mrgstr(:) ! temporary string + character(*), parameter :: subname = '(prep_rof_merge) ' + + !----------------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + lsize = mct_aVect_lsize(x2r_r) + + if (first_time) then + nflds = mct_aVect_nRattr(x2r_r) + + allocate(mrgstr(nflds)) + do i = 1,nflds + field = mct_aVect_getRList2c(i, x2r_r) + mrgstr(i) = subname//'x2r%'//trim(field)//' =' + enddo + + index_l2x_Flrl_rofsur = mct_aVect_indexRA(l2x_r,'Flrl_rofsur' ) + index_l2x_Flrl_rofgwl = mct_aVect_indexRA(l2x_r,'Flrl_rofgwl' ) + index_l2x_Flrl_rofsub = mct_aVect_indexRA(l2x_r,'Flrl_rofsub' ) + index_l2x_Flrl_rofdto = mct_aVect_indexRA(l2x_r,'Flrl_rofdto' ) + if (have_irrig_field) then + index_l2x_Flrl_irrig = mct_aVect_indexRA(l2x_r,'Flrl_irrig' ) + end if + index_l2x_Flrl_rofi = mct_aVect_indexRA(l2x_r,'Flrl_rofi' ) + index_x2r_Flrl_rofsur = mct_aVect_indexRA(x2r_r,'Flrl_rofsur' ) + index_x2r_Flrl_rofgwl = mct_aVect_indexRA(x2r_r,'Flrl_rofgwl' ) + index_x2r_Flrl_rofsub = mct_aVect_indexRA(x2r_r,'Flrl_rofsub' ) + index_x2r_Flrl_rofdto = mct_aVect_indexRA(x2r_r,'Flrl_rofdto' ) + index_x2r_Flrl_rofi = mct_aVect_indexRA(x2r_r,'Flrl_rofi' ) + if (have_irrig_field) then + index_x2r_Flrl_irrig = mct_aVect_indexRA(x2r_r,'Flrl_irrig' ) + end if + index_l2x_Flrl_rofl_16O = mct_aVect_indexRA(l2x_r,'Flrl_rofl_16O', perrWith='quiet' ) + + if ( index_l2x_Flrl_rofl_16O /= 0 ) flds_wiso_rof = .true. + if ( flds_wiso_rof ) then + index_l2x_Flrl_rofi_16O = mct_aVect_indexRA(l2x_r,'Flrl_rofi_16O' ) + index_x2r_Flrl_rofl_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofl_16O' ) + index_x2r_Flrl_rofi_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofi_16O' ) + + index_l2x_Flrl_rofl_18O = mct_aVect_indexRA(l2x_r,'Flrl_rofl_18O' ) + index_l2x_Flrl_rofi_18O = mct_aVect_indexRA(l2x_r,'Flrl_rofi_18O' ) + index_x2r_Flrl_rofl_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofl_18O' ) + index_x2r_Flrl_rofi_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofi_18O' ) + + index_l2x_Flrl_rofl_HDO = mct_aVect_indexRA(l2x_r,'Flrl_rofl_HDO' ) + index_l2x_Flrl_rofi_HDO = mct_aVect_indexRA(l2x_r,'Flrl_rofi_HDO' ) + index_x2r_Flrl_rofl_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofl_HDO' ) + index_x2r_Flrl_rofi_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofi_HDO' ) + end if + index_lfrac = mct_aVect_indexRA(fractions_r,"lfrac") + + index_lfrac = mct_aVect_indexRA(fractions_r,"lfrac") + + mrgstr(index_x2r_Flrl_rofsur) = trim(mrgstr(index_x2r_Flrl_rofsur))//' = '// & + 'lfrac*l2x%Flrl_rofsur' + mrgstr(index_x2r_Flrl_rofgwl) = trim(mrgstr(index_x2r_Flrl_rofgwl))//' = '// & + 'lfrac*l2x%Flrl_rofgwl' + mrgstr(index_x2r_Flrl_rofsub) = trim(mrgstr(index_x2r_Flrl_rofsub))//' = '// & + 'lfrac*l2x%Flrl_rofsub' + mrgstr(index_x2r_Flrl_rofdto) = trim(mrgstr(index_x2r_Flrl_rofdto))//' = '// & + 'lfrac*l2x%Flrl_rofdto' + mrgstr(index_x2r_Flrl_rofi) = trim(mrgstr(index_x2r_Flrl_rofi))//' = '// & + 'lfrac*l2x%Flrl_rofi' + if (have_irrig_field) then + mrgstr(index_x2r_Flrl_irrig) = trim(mrgstr(index_x2r_Flrl_irrig))//' = '// & + 'lfrac*l2x%Flrl_irrig' + end if + if ( flds_wiso_rof ) then + mrgstr(index_x2r_Flrl_rofl_16O) = trim(mrgstr(index_x2r_Flrl_rofl_16O))//' = '// & + 'lfrac*l2x%Flrl_rofl_16O' + mrgstr(index_x2r_Flrl_rofi_16O) = trim(mrgstr(index_x2r_Flrl_rofi_16O))//' = '// & + 'lfrac*l2x%Flrl_rofi_16O' + mrgstr(index_x2r_Flrl_rofl_18O) = trim(mrgstr(index_x2r_Flrl_rofl_18O))//' = '// & + 'lfrac*l2x%Flrl_rofl_18O' + mrgstr(index_x2r_Flrl_rofi_18O) = trim(mrgstr(index_x2r_Flrl_rofi_18O))//' = '// & + 'lfrac*l2x%Flrl_rofi_18O' + mrgstr(index_x2r_Flrl_rofl_HDO) = trim(mrgstr(index_x2r_Flrl_rofl_HDO))//' = '// & + 'lfrac*l2x%Flrl_rofl_HDO' + mrgstr(index_x2r_Flrl_rofi_HDO) = trim(mrgstr(index_x2r_Flrl_rofi_HDO))//' = '// & + 'lfrac*l2x%Flrl_rofi_HDO' + end if + end if + + do i = 1,lsize + lfrac = fractions_r%rAttr(index_lfrac,i) + x2r_r%rAttr(index_x2r_Flrl_rofsur,i) = l2x_r%rAttr(index_l2x_Flrl_rofsur,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofgwl,i) = l2x_r%rAttr(index_l2x_Flrl_rofgwl,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofsub,i) = l2x_r%rAttr(index_l2x_Flrl_rofsub,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofdto,i) = l2x_r%rAttr(index_l2x_Flrl_rofdto,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofi,i) = l2x_r%rAttr(index_l2x_Flrl_rofi,i) * lfrac + if (have_irrig_field) then + x2r_r%rAttr(index_x2r_Flrl_irrig,i) = l2x_r%rAttr(index_l2x_Flrl_irrig,i) * lfrac + end if + if ( flds_wiso_rof ) then + x2r_r%rAttr(index_x2r_Flrl_rofl_16O,i) = l2x_r%rAttr(index_l2x_Flrl_rofl_16O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofi_16O,i) = l2x_r%rAttr(index_l2x_Flrl_rofi_16O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofl_18O,i) = l2x_r%rAttr(index_l2x_Flrl_rofl_18O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofi_18O,i) = l2x_r%rAttr(index_l2x_Flrl_rofi_18O,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofl_HDO,i) = l2x_r%rAttr(index_l2x_Flrl_rofl_HDO,i) * lfrac + x2r_r%rAttr(index_x2r_Flrl_rofi_HDO,i) = l2x_r%rAttr(index_l2x_Flrl_rofi_HDO,i) * lfrac + end if + end do + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do i = 1,nflds + write(logunit,'(A)') trim(mrgstr(i)) + enddo + endif + deallocate(mrgstr) + endif + + first_time = .false. + + end subroutine prep_rof_merge + + !================================================================================================ + + subroutine prep_rof_calc_l2r_rx(fractions_lx, timer) + !--------------------------------------------------------------- + ! Description + ! Create l2r_rx (note that l2r_rx is a local module variable) + ! + ! Arguments + type(mct_aVect) , intent(in) :: fractions_lx(:) + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eri, eli, efi + type(mct_avect), pointer :: r2x_rx + type(seq_map) , pointer :: mapper_Fr2l ! flux mapper for mapping rof -> lnd + character(*), parameter :: subname = '(prep_rof_calc_l2r_rx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eri = 1,num_inst_rof + eli = mod((eri-1),num_inst_lnd) + 1 + efi = mod((eri-1),num_inst_frc) + 1 + + ! If the options to this seq_map_map call change (e.g., the use of avwts), similar + ! changes should be made in map_lnd2rof_irrig. + call seq_map_map(mapper_Fl2r, l2racc_lx(eli), l2r_rx(eri), & + fldlist=lnd2rof_normal_fluxes, norm=.true., & + avwts_s=fractions_lx(efi), avwtsfld_s='lfrin') + + if (have_irrig_field) then + r2x_rx => component_get_c2x_cx(rof(eri)) + mapper_Fr2l => prep_lnd_get_mapper_Fr2l() + call map_lnd2rof_irrig( & + l2r_l = l2racc_lx(eli), & + r2x_r = r2x_rx, & + irrig_flux_field = irrig_flux_field, & + avwts_s = fractions_lx(efi), & + avwtsfld_s = 'lfrin', & + mapper_Fl2r = mapper_Fl2r, & + mapper_Fr2l = mapper_Fr2l, & + l2r_r = l2r_rx(eri)) + end if + end do + call t_drvstopf (trim(timer)) + + end subroutine prep_rof_calc_l2r_rx + + !================================================================================================ + + function prep_rof_get_l2racc_lx() + type(mct_aVect), pointer :: prep_rof_get_l2racc_lx(:) + prep_rof_get_l2racc_lx => l2racc_lx(:) + end function prep_rof_get_l2racc_lx + + function prep_rof_get_l2racc_lx_cnt() + integer, pointer :: prep_rof_get_l2racc_lx_cnt + prep_rof_get_l2racc_lx_cnt => l2racc_lx_cnt + end function prep_rof_get_l2racc_lx_cnt + + function prep_rof_get_mapper_Fl2r() + type(seq_map), pointer :: prep_rof_get_mapper_Fl2r + prep_rof_get_mapper_Fl2r => mapper_Fl2r + end function prep_rof_get_mapper_Fl2r + +end module prep_rof_mod diff --git a/driver-mct/main/prep_wav_mod.F90 b/driver-mct/main/prep_wav_mod.F90 new file mode 100644 index 000000000000..3384f3560f35 --- /dev/null +++ b/driver-mct/main/prep_wav_mod.F90 @@ -0,0 +1,361 @@ +module prep_wav_mod + + use shr_kind_mod , only: r8 => SHR_KIND_R8 + use shr_kind_mod , only: cs => SHR_KIND_CS + use shr_kind_mod , only: cl => SHR_KIND_CL + use shr_sys_mod , only: shr_sys_abort, shr_sys_flush + use seq_comm_mct , only: num_inst_atm, num_inst_ice, num_inst_ocn + use seq_comm_mct , only: num_inst_wav, num_inst_frc + use seq_comm_mct , only: CPLID, WAVID, logunit + use seq_comm_mct , only: seq_comm_getdata=>seq_comm_setptrs + use seq_infodata_mod, only: seq_infodata_getdata, seq_infodata_type + use seq_map_type_mod + use seq_map_mod + use seq_flds_mod + use t_drv_timers_mod + use mct_mod + use perf_mod + use component_type_mod, only: component_get_x2c_cx, component_get_c2x_cx + use component_type_mod, only: wav, ocn, ice, atm + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: prep_wav_init + public :: prep_wav_mrg + + public :: prep_wav_calc_a2x_wx + public :: prep_wav_calc_o2x_wx + public :: prep_wav_calc_i2x_wx + + !-------------------------------------------------------------------------- + ! Private interfaces + !-------------------------------------------------------------------------- + + private :: prep_wav_merge + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! mappers + type(seq_map), pointer :: mapper_sa2w + type(seq_map), pointer :: mapper_so2w + type(seq_map), pointer :: mapper_si2w + + ! attribute vectors + type(mct_aVect), pointer :: o2x_wx(:) ! Ocn export, wav grid, cpl pes + type(mct_aVect), pointer :: i2x_wx(:) ! Ice export, wav grid, cpl pes + type(mct_aVect), pointer :: a2x_wx(:) ! Atm export, wav grid, cpl pes + + ! accumulation variables + ! none at this time + + ! seq_comm_getData variables + integer :: mpicom_CPLID ! MPI cpl communicator + !================================================================================================ + +contains + + !================================================================================================ + + subroutine prep_wav_init(infodata, atm_c2_wav, ocn_c2_wav, ice_c2_wav) + + !--------------------------------------------------------------- + ! Description + ! Initialize module attribute vectors and all other non-mapping + ! module variables + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in) :: atm_c2_wav ! .true. => atm to wav coupling on + logical , intent(in) :: ocn_c2_wav ! .true. => ocn to wav coupling on + logical , intent(in) :: ice_c2_wav ! .true. => ocn to wav coupling on + ! + ! Local Variables + integer :: eai , eoi, eii, ewi + integer :: lsize_w + logical :: samegrid_ow ! samegrid ocean and wave + logical :: samegrid_aw ! samegrid atm and wave + logical :: iamroot_CPLID ! .true. => CPLID masterproc + logical :: esmf_map_flag ! .true. => use esmf for mapping + logical :: wav_present ! .true. => wav is present + character(CL) :: atm_gnam ! atm grid + character(CL) :: ocn_gnam ! ocn grid + character(CL) :: wav_gnam ! wav grid + type(mct_avect) , pointer :: w2x_wx + character(*) , parameter :: subname = '(prep_wav_init)' + character(*) , parameter :: F00 = "('"//subname//" : ', 4A )" + !--------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + wav_present=wav_present , & + ocn_gnam=ocn_gnam , & + wav_gnam=wav_gnam , & + atm_gnam=atm_gnam , & + esmf_map_flag=esmf_map_flag ) + + allocate(mapper_sa2w) + allocate(mapper_so2w) + allocate(mapper_si2w) + + if (wav_present) then + + call seq_comm_getData(CPLID, mpicom=mpicom_CPLID, iamroot=iamroot_CPLID) + + w2x_wx => component_get_c2x_cx(wav(1)) + lsize_w = mct_aVect_lsize(w2x_wx) + + allocate(a2x_wx(num_inst_atm)) + do eai = 1,num_inst_atm + call mct_aVect_init(a2x_wx(eai), rList=seq_flds_a2x_fields, lsize=lsize_w) + call mct_aVect_zero(a2x_wx(eai)) + enddo + allocate(o2x_wx(num_inst_ocn)) + do eoi = 1,num_inst_ocn + call mct_aVect_init(o2x_wx(eoi), rList=seq_flds_o2x_fields, lsize=lsize_w) + call mct_aVect_zero(o2x_wx(eoi)) + enddo + allocate(i2x_wx(num_inst_ice)) + do eii = 1,num_inst_ice + call mct_aVect_init(i2x_wx(eii), rList=seq_flds_i2x_fields, lsize=lsize_w) + call mct_aVect_zero(i2x_wx(eii)) + enddo + + samegrid_ow = .true. + samegrid_aw = .true. + if (trim(ocn_gnam) /= trim(wav_gnam)) samegrid_ow = .false. + if (trim(atm_gnam) /= trim(wav_gnam)) samegrid_aw = .false. + + if (atm_c2_wav) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Sa2w' + end if + call seq_map_init_rcfile(mapper_Sa2w, atm(1), wav(1), & + 'seq_maps.rc','atm2wav_smapname:','atm2wav_smaptype:',samegrid_aw, & + 'mapper_Sa2w initialization') + endif + call shr_sys_flush(logunit) + if (ocn_c2_wav) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_So2w' + end if + call seq_map_init_rcfile(mapper_So2w, ocn(1), wav(1), & + 'seq_maps.rc','ocn2wav_smapname:','ocn2wav_smaptype:',samegrid_ow, & + 'mapper_So2w initialization') + endif + call shr_sys_flush(logunit) !TODO ??? is this in Tony's code + if (ice_c2_wav) then + if (iamroot_CPLID) then + write(logunit,*) ' ' + write(logunit,F00) 'Initializing mapper_Si2w' + end if + call seq_map_init_rcfile(mapper_Si2w, ice(1), wav(1), & + 'seq_maps.rc','ice2wav_smapname:','ice2wav_smaptype:',samegrid_ow, & + 'mapper_Si2w initialization') + endif + call shr_sys_flush(logunit) + + end if + + end subroutine prep_wav_init + + !================================================================================================ + + subroutine prep_wav_mrg(infodata, fractions_wx, timer_mrg) + + !--------------------------------------------------------------- + ! Description + ! Merge all wav inputs + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type(mct_aVect) , intent(in) :: fractions_wx(:) + character(len=*) , intent(in) :: timer_mrg + ! + ! Local Variables + integer :: eai, eoi, eii, ewi, efi + type(mct_avect), pointer :: x2w_wx + character(*), parameter :: subname = '(prep_wav_mrg)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer_mrg),barrier=mpicom_CPLID) + do ewi = 1,num_inst_wav + ! Use fortran mod to address ensembles in merge + eai = mod((ewi-1),num_inst_atm) + 1 + eoi = mod((ewi-1),num_inst_ocn) + 1 + eii = mod((ewi-1),num_inst_ice) + 1 + efi = mod((ewi-1),num_inst_frc) + 1 + + x2w_wx => component_get_x2c_cx(wav(ewi)) + + call prep_wav_merge(a2x_wx(eai), o2x_wx(eoi), i2x_wx(eii), fractions_wx(efi), x2w_wx) + enddo + call t_drvstopf (trim(timer_mrg)) + + end subroutine prep_wav_mrg + + !================================================================================================ + + subroutine prep_wav_merge(a2x_w, o2x_w, i2x_w, frac_w, x2w_w) + + !----------------------------------------------------------------------- + ! Arguments + type(mct_aVect), intent(in) :: a2x_w ! input + type(mct_aVect), intent(in) :: o2x_w ! input + type(mct_aVect), intent(in) :: i2x_w ! input + type(mct_aVect), intent(in) :: frac_w ! input + type(mct_aVect), intent(inout) :: x2w_w ! output + !----------------------------------------------------------------------- + integer :: nflds,i,i1,o1 + logical :: iamroot + logical, save :: first_time = .true. + character(CL),allocatable :: mrgstr(:) ! temporary string + character(CL) :: field ! string converted to char + type(mct_aVect_sharedindices),save :: a2x_sharedindices + type(mct_aVect_sharedindices),save :: o2x_sharedindices + type(mct_aVect_sharedindices),save :: i2x_sharedindices + character(*), parameter :: subname = '(prep_wav_merge) ' + + !----------------------------------------------------------------------- + + call seq_comm_getdata(CPLID, iamroot=iamroot) + + if (first_time) then + nflds = mct_aVect_nRattr(x2w_w) + + allocate(mrgstr(nflds)) + do i = 1,nflds + field = mct_aVect_getRList2c(i, x2w_w) + mrgstr(i) = subname//'x2w%'//trim(field)//' =' + enddo + + call mct_aVect_setSharedIndices(a2x_w, x2w_w, a2x_SharedIndices) + ! QL, 150625, bug? + ! a2x_SharedIndices -> o2x_SharedIndices + ! a2x_SharedIndices -> i2x_SharedIndices + call mct_aVect_setSharedIndices(o2x_w, x2w_w, o2x_SharedIndices) + call mct_aVect_setSharedIndices(i2x_w, x2w_w, i2x_SharedIndices) + + !--- document copy operations --- + do i=1,a2x_SharedIndices%shared_real%num_indices + i1=a2x_SharedIndices%shared_real%aVindices1(i) + o1=a2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, a2x_w) + mrgstr(o1) = trim(mrgstr(o1))//' = a2x%'//trim(field) + enddo + do i=1,o2x_SharedIndices%shared_real%num_indices + i1=o2x_SharedIndices%shared_real%aVindices1(i) + o1=o2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, o2x_w) + mrgstr(o1) = trim(mrgstr(o1))//' = o2x%'//trim(field) + enddo + do i=1,i2x_SharedIndices%shared_real%num_indices + i1=i2x_SharedIndices%shared_real%aVindices1(i) + o1=i2x_SharedIndices%shared_real%aVindices2(i) + field = mct_aVect_getRList2c(i1, i2x_w) + mrgstr(o1) = trim(mrgstr(o1))//' = i2x%'//trim(field) + enddo + endif + + ! Create input wave state directly from atm, ocn, ice output state + + call mct_avect_zero(x2w_w) + call mct_aVect_copy(aVin=a2x_w, aVout=x2w_w, vector=mct_usevector, sharedIndices=a2x_SharedIndices) + call mct_aVect_copy(aVin=o2x_w, aVout=x2w_w, vector=mct_usevector, sharedIndices=o2x_SharedIndices) + call mct_aVect_copy(aVin=i2x_w, aVout=x2w_w, vector=mct_usevector, sharedIndices=i2x_SharedIndices) + + if (first_time) then + if (iamroot) then + write(logunit,'(A)') subname//' Summary:' + do i = 1,nflds + write(logunit,'(A)') trim(mrgstr(i)) + enddo + endif + deallocate(mrgstr) + endif + + first_time = .false. + + end subroutine prep_wav_merge + + !================================================================================================ + + subroutine prep_wav_calc_a2x_wx(timer) + !--------------------------------------------------------------- + ! Description + ! Create a2x_wx (note that a2x_wx is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eai + type(mct_aVect), pointer :: a2x_ax + character(*), parameter :: subname = '(prep_wav_calc_a2x_wx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eai = 1,num_inst_atm + a2x_ax => component_get_c2x_cx(atm(eai)) + call seq_map_map(mapper_Sa2w, a2x_ax, a2x_wx(eai), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + end subroutine prep_wav_calc_a2x_wx + + !================================================================================================ + + subroutine prep_wav_calc_o2x_wx(timer) + !--------------------------------------------------------------- + ! Description + ! Create o2x_wx (note that o2x_wx is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eoi + type(mct_aVect), pointer :: o2x_ox + character(*), parameter :: subname = '(prep_wav_calc_o2x_wx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eoi = 1,num_inst_ocn + o2x_ox => component_get_c2x_cx(ocn(eoi)) + call seq_map_map(mapper_So2w, o2x_ox, o2x_wx(eoi), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + end subroutine prep_wav_calc_o2x_wx + + !================================================================================================ + + subroutine prep_wav_calc_i2x_wx(timer) + !--------------------------------------------------------------- + ! Description + ! Create i2x_wx (note that i2x_wx is a local module variable) + ! + ! Arguments + character(len=*), intent(in) :: timer + ! + ! Local Variables + integer :: eii + type(mct_aVect), pointer :: i2x_ix + character(*), parameter :: subname = '(prep_wav_calc_i2x_wx)' + !--------------------------------------------------------------- + + call t_drvstartf (trim(timer),barrier=mpicom_CPLID) + do eii = 1,num_inst_ice + i2x_ix => component_get_c2x_cx(ice(eii)) + call seq_map_map(mapper_Si2w, i2x_ix, i2x_wx(eii), norm=.true.) + enddo + call t_drvstopf (trim(timer)) + end subroutine prep_wav_calc_i2x_wx + +end module prep_wav_mod diff --git a/driver-mct/main/seq_diag_mct.F90 b/driver-mct/main/seq_diag_mct.F90 new file mode 100644 index 000000000000..513050c89045 --- /dev/null +++ b/driver-mct/main/seq_diag_mct.F90 @@ -0,0 +1,2526 @@ +!=============================================================================== +! +! !MODULE: seq_diag_mod -- computes spatial \& time averages of fluxed quatities +! +! !DESCRIPTION: +! The coupler is required to do certain diagnostics, those calculations are +! located in this module. +! +! !REMARKS: +! CESM sign convention for fluxes is positive downward with hierarchy being +! atm/glc/lnd/rof/ice/ocn +! Sign convention: +! positive value <=> the model is gaining water, heat, momentum, etc. +! Unit convention: +! heat flux ~ W/m^2 +! momentum flux ~ N/m^2 +! water flux ~ (kg/s)/m^2 +! salt flux ~ (kg/s)/m^2 +! +! !REVISION HISTORY: +! 2012-aug-20 - T. Craig - add rof component +! 2008-jul-10 - T. Craig - updated budget implementation +! 2007-may-07 - B. Kauffman - initial port to cpl7. +! 2002-nov-21 - R. Jacob - initial port to cpl6. +! 199x-mmm-dd - B. Kauffman - original version in cpl4. +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_diag_mct + +! !USES: + + use shr_kind_mod, only: r8 => shr_kind_r8, in=>shr_kind_in + use shr_kind_mod, only: i8 => shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_sys_mod ! system calls + use shr_mpi_mod ! mpi wrappers + use shr_const_mod ! shared constants + use mct_mod ! mct wrappers + use esmf + + use seq_comm_mct ! mpi comm groups & related + use seq_timemgr_mod + use component_type_mod + use seq_infodata_mod, only : seq_infodata_type, seq_infodata_getdata + + implicit none + save + private + +! !PUBLIC TYPES: + + ! none + +!PUBLIC MEMBER FUNCTIONS: + + public seq_diag_zero_mct + public seq_diag_atm_mct + public seq_diag_lnd_mct + public seq_diag_rof_mct + public seq_diag_glc_mct + public seq_diag_ocn_mct + public seq_diag_ice_mct + public seq_diag_accum_mct + public seq_diag_sum0_mct + public seq_diag_print_mct + public seq_diag_avect_mct + public seq_diag_avloc_mct + public seq_diag_avdiff_mct + +!EOP + + !---------------------------------------------------------------------------- + ! Local data + !---------------------------------------------------------------------------- + + !----- local constants ----- + real(r8),parameter :: HFLXtoWFLX = & ! water flux implied by latent heat of fusion + & - (shr_const_ocn_ref_sal-shr_const_ice_ref_sal) / & + & (shr_const_ocn_ref_sal*shr_const_latice) + + real(r8),parameter :: SFLXtoWFLX = & ! water flux implied by salt flux + ! WFLX (kg/m^2s) = -SFLX (kg/m^2s) + ! / ocn_ref_sal (psu) (34.7g/kg) + ! / 1.e-3 kg/g + -1._r8/(shr_const_ocn_ref_sal*1.e-3_r8) + + + !--- C for component --- + !--- "r" is recieve in the coupler, "s" is send from the coupler + + integer(in),parameter :: c_size = 22 + + integer(in),parameter :: c_atm_as = 1 ! model index: atm + integer(in),parameter :: c_atm_ar = 2 ! model index: atm + integer(in),parameter :: c_inh_is = 3 ! model index: ice, northern + integer(in),parameter :: c_inh_ir = 4 ! model index: ice, northern + integer(in),parameter :: c_ish_is = 5 ! model index: ice, southern + integer(in),parameter :: c_ish_ir = 6 ! model index: ice, southern + integer(in),parameter :: c_lnd_ls = 7 ! model index: lnd + integer(in),parameter :: c_lnd_lr = 8 ! model index: lnd + integer(in),parameter :: c_ocn_os = 9 ! model index: ocn + integer(in),parameter :: c_ocn_or =10 ! model index: ocn + integer(in),parameter :: c_rof_rs =11 ! model index: rof + integer(in),parameter :: c_rof_rr =12 ! model index: rof + integer(in),parameter :: c_glc_gs =13 ! model index: glc + integer(in),parameter :: c_glc_gr =14 ! model index: glc + ! --- on atm grid --- + integer(in),parameter :: c_inh_as =15 ! model index: ice, northern + integer(in),parameter :: c_inh_ar =16 ! model index: ice, northern + integer(in),parameter :: c_ish_as =17 ! model index: ice, southern + integer(in),parameter :: c_ish_ar =18 ! model index: ice, southern + integer(in),parameter :: c_lnd_as =19 ! model index: lnd + integer(in),parameter :: c_lnd_ar =20 ! model index: lnd + integer(in),parameter :: c_ocn_as =21 ! model index: ocn + integer(in),parameter :: c_ocn_ar =22 ! model index: ocn + + character(len=8),parameter :: cname(c_size) = & + (/' c2a_atm',' a2c_atm',' c2i_inh',' i2c_inh',' c2i_ish',' i2c_ish', & + ' c2l_lnd',' l2c_lnd',' c2o_ocn',' o2c_ocn',' c2r_rof',' r2c_rof', & + ' c2g_glc',' g2c_glc', & + ' c2a_inh',' a2c_inh',' c2a_ish',' a2c_ish', & + ' c2a_lnd',' a2c_lnd',' c2a_ocn',' a2c_ocn' /) + + !--- F for field --- + + integer(in),parameter :: f_area = 1 ! area (wrt to unit sphere) + integer(in),parameter :: f_hfrz = 2 ! heat : latent, freezing + integer(in),parameter :: f_hmelt = 3 ! heat : latent, melting + integer(in),parameter :: f_hswnet = 4 ! heat : short wave, net + integer(in),parameter :: f_hlwdn = 5 ! heat : longwave down + integer(in),parameter :: f_hlwup = 6 ! heat : longwave up + integer(in),parameter :: f_hlatv = 7 ! heat : latent, vaporization + integer(in),parameter :: f_hlatf = 8 ! heat : latent, fusion, snow + integer(in),parameter :: f_hioff = 9 ! heat : latent, fusion, frozen runoff + integer(in),parameter :: f_hsen =10 ! heat : sensible + integer(in),parameter :: f_wfrz =11 ! water: freezing + integer(in),parameter :: f_wmelt =12 ! water: melting + integer(in),parameter :: f_wrain =13 ! water: precip, liquid + integer(in),parameter :: f_wsnow =14 ! water: precip, frozen + integer(in),parameter :: f_wevap =15 ! water: evaporation + integer(in),parameter :: f_wsalt =16 ! water: water equivalent of salt flux + integer(in),parameter :: f_wroff =17 ! water: runoff/flood + integer(in),parameter :: f_wioff =18 ! water: frozen runoff + integer(in),parameter :: f_wfrz_16O =19 ! water: freezing + integer(in),parameter :: f_wmelt_16O =20 ! water: melting + integer(in),parameter :: f_wrain_16O =21 ! water: precip, liquid + integer(in),parameter :: f_wsnow_16O =22 ! water: precip, frozen + integer(in),parameter :: f_wevap_16O =23 ! water: evaporation + integer(in),parameter :: f_wroff_16O =24 ! water: runoff/flood + integer(in),parameter :: f_wioff_16O =25 ! water: frozen runoff + integer(in),parameter :: f_wfrz_18O =26 ! water: freezing + integer(in),parameter :: f_wmelt_18O =27 ! water: melting + integer(in),parameter :: f_wrain_18O =28 ! water: precip, liquid + integer(in),parameter :: f_wsnow_18O =29 ! water: precip, frozen + integer(in),parameter :: f_wevap_18O =30 ! water: evaporation + integer(in),parameter :: f_wroff_18O =31 ! water: runoff/flood + integer(in),parameter :: f_wioff_18O =32 ! water: frozen runoff + integer(in),parameter :: f_wfrz_HDO =33 ! water: freezing + integer(in),parameter :: f_wmelt_HDO =34 ! water: melting + integer(in),parameter :: f_wrain_HDO =35 ! water: precip, liquid + integer(in),parameter :: f_wsnow_HDO =36 ! water: precip, frozen + integer(in),parameter :: f_wevap_HDO =37 ! water: evaporation + integer(in),parameter :: f_wroff_HDO =38 ! water: runoff/flood + integer(in),parameter :: f_wioff_HDO =39 ! water: frozen runoff + + integer(in),parameter :: f_size = f_wioff_HDO ! Total array size of all elements + integer(in),parameter :: f_a = f_area ! 1st index for area + integer(in),parameter :: f_a_end = f_area ! last index for area + integer(in),parameter :: f_h = f_hfrz ! 1st index for heat + integer(in),parameter :: f_h_end = f_hsen ! Last index for heat + integer(in),parameter :: f_w = f_wfrz ! 1st index for water + integer(in),parameter :: f_w_end = f_wioff ! Last index for water + integer(in),parameter :: f_16O = f_wfrz_16O ! 1st index for 16O water isotope + integer(in),parameter :: f_18O = f_wfrz_18O ! 1st index for 18O water isotope + integer(in),parameter :: f_HDO = f_wfrz_HDO ! 1st index for HDO water isotope + integer(in),parameter :: f_16O_end = f_wioff_16O ! Last index for 16O water isotope + integer(in),parameter :: f_18O_end = f_wioff_18O ! Last index for 18O water isotope + integer(in),parameter :: f_HDO_end = f_wioff_HDO ! Last index for HDO water isotope + + character(len=12),parameter :: fname(f_size) = & + + (/' area',' hfreeze',' hmelt',' hnetsw',' hlwdn', & + ' hlwup',' hlatvap',' hlatfus',' hiroff',' hsen', & + ' wfreeze',' wmelt',' wrain',' wsnow', & + ' wevap',' weqsaltf',' wrunoff',' wfrzrof', & + ' wfreeze_16O',' wmelt_16O',' wrain_16O',' wsnow_16O', & + ' wevap_16O',' wrunoff_16O',' wfrzrof_16O', & + ' wfreeze_18O',' wmelt_18O',' wrain_18O',' wsnow_18O', & + ' wevap_18O',' wrunoff_18O',' wfrzrof_18O', & + ' wfreeze_HDO',' wmelt_HDO',' wrain_HDO',' wsnow_HDO', & + ' wevap_HDO',' wrunoff_HDO',' wfrzrof_HDO'/) + + !--- P for period --- + + integer(in),parameter :: p_size = 5 + + integer(in),parameter :: p_inst = 1 + integer(in),parameter :: p_day = 2 + integer(in),parameter :: p_mon = 3 + integer(in),parameter :: p_ann = 4 + integer(in),parameter :: p_inf = 5 + + character(len=8),parameter :: pname(p_size) = & + (/' inst',' daily',' monthly',' annual','all_time' /) + + logical :: flds_wiso ! If water isotope fields are active + +! !PUBLIC DATA MEMBERS + + !--- time-averaged (annual?) global budge diagnostics --- + !--- note: call sum0 then save budg_dataG and budg_ns on restart from/to root pe --- + real(r8),public :: budg_dataL(f_size,c_size,p_size) ! local sum, valid on all pes + real(r8),public :: budg_dataG(f_size,c_size,p_size) ! global sum, valid only on root pe + real(r8),public :: budg_ns (f_size,c_size,p_size) ! counter, valid only on root pe + + character(len=*),parameter :: afldname = 'aream' + character(len=*),parameter :: latname = 'lat' + character(len=*),parameter :: afracname = 'afrac' + character(len=*),parameter :: lfracname = 'lfrac' + character(len=*),parameter :: ofracname = 'ofrac' + character(len=*),parameter :: ifracname = 'ifrac' + + character(*),parameter :: modName = "(seq_diag_mct) " + + integer(in),parameter :: debug = 0 ! internal debug level + +! !PRIVATE DATA MEMBERS + + integer :: index_a2x_Faxa_swnet + integer :: index_a2x_Faxa_lwdn + integer :: index_a2x_Faxa_rainc + integer :: index_a2x_Faxa_rainl + integer :: index_a2x_Faxa_snowc + integer :: index_a2x_Faxa_snowl + + integer :: index_x2a_Faxx_lwup + integer :: index_x2a_Faxx_lat + integer :: index_x2a_Faxx_sen + integer :: index_x2a_Faxx_evap + + integer :: index_l2x_Fall_swnet + integer :: index_l2x_Fall_lwup + integer :: index_l2x_Fall_lat + integer :: index_l2x_Fall_sen + integer :: index_l2x_Fall_evap + integer :: index_l2x_Flrl_rofsur + integer :: index_l2x_Flrl_rofgwl + integer :: index_l2x_Flrl_rofsub + integer :: index_l2x_Flrl_rofdto + integer :: index_l2x_Flrl_rofi + integer :: index_l2x_Flrl_irrig + + integer :: index_x2l_Faxa_lwdn + integer :: index_x2l_Faxa_rainc + integer :: index_x2l_Faxa_rainl + integer :: index_x2l_Faxa_snowc + integer :: index_x2l_Faxa_snowl + integer :: index_x2l_Flrr_flood + + integer :: index_r2x_Forr_rofl + integer :: index_r2x_Forr_rofi + integer :: index_r2x_Firr_rofi + integer :: index_r2x_Flrr_flood + + integer :: index_x2r_Flrl_rofsur + integer :: index_x2r_Flrl_rofgwl + integer :: index_x2r_Flrl_rofsub + integer :: index_x2r_Flrl_rofdto + integer :: index_x2r_Flrl_rofi + integer :: index_x2r_Flrl_irrig + + integer :: index_o2x_Fioo_frazil ! currently used by acme + integer :: index_o2x_Fioo_q ! currently used by cesm + + integer :: index_xao_Faox_lwup + integer :: index_xao_Faox_lat + integer :: index_xao_Faox_sen + integer :: index_xao_Faox_evap + + integer :: index_x2o_Foxx_lwup + integer :: index_x2o_Foxx_lat + integer :: index_x2o_Foxx_sen + integer :: index_x2o_Foxx_evap + integer :: index_x2o_Foxx_swnet + integer :: index_x2o_Foxx_rofl + integer :: index_x2o_Foxx_rofi + integer :: index_x2o_Faxa_lwdn + integer :: index_x2o_Faxa_rain + integer :: index_x2o_Faxa_snow + integer :: index_x2o_Fioi_melth + integer :: index_x2o_Fioi_meltw + integer :: index_x2o_Fioi_salt + + integer :: index_i2x_Fioi_melth + integer :: index_i2x_Fioi_meltw + integer :: index_i2x_Fioi_salt + integer :: index_i2x_Faii_swnet + integer :: index_i2x_Fioi_swpen + integer :: index_i2x_Faii_lwup + integer :: index_i2x_Faii_lat + integer :: index_i2x_Faii_sen + integer :: index_i2x_Faii_evap + + integer :: index_x2i_Faxa_lwdn + integer :: index_x2i_Faxa_rain + integer :: index_x2i_Faxa_snow + integer :: index_x2i_Fioo_frazil !currently used by acme + integer :: index_x2i_Fioo_q !currently used by cesm + integer :: index_x2i_Fixx_rofi + + integer :: index_g2x_Fogg_rofl + integer :: index_g2x_Fogg_rofi + integer :: index_g2x_Figg_rofi + + integer :: index_x2o_Foxx_rofl_16O + integer :: index_x2o_Foxx_rofi_16O + integer :: index_x2o_Foxx_rofl_18O + integer :: index_x2o_Foxx_rofi_18O + integer :: index_x2o_Foxx_rofl_HDO + integer :: index_x2o_Foxx_rofi_HDO + + integer :: index_a2x_Faxa_rainc_16O + integer :: index_a2x_Faxa_rainc_18O + integer :: index_a2x_Faxa_rainc_HDO + integer :: index_a2x_Faxa_rainl_16O + integer :: index_a2x_Faxa_rainl_18O + integer :: index_a2x_Faxa_rainl_HDO + integer :: index_a2x_Faxa_snowc_16O + integer :: index_a2x_Faxa_snowc_18O + integer :: index_a2x_Faxa_snowc_HDO + integer :: index_a2x_Faxa_snowl_16O + integer :: index_a2x_Faxa_snowl_18O + integer :: index_a2x_Faxa_snowl_HDO + + integer :: index_x2a_Faxx_evap_16O + integer :: index_x2a_Faxx_evap_18O + integer :: index_x2a_Faxx_evap_HDO + + integer :: index_l2x_Fall_evap_16O + integer :: index_l2x_Fall_evap_18O + integer :: index_l2x_Fall_evap_HDO + + integer :: index_l2x_Flrl_rofl_16O + integer :: index_l2x_Flrl_rofl_18O + integer :: index_l2x_Flrl_rofl_HDO + integer :: index_l2x_Flrl_rofi_16O + integer :: index_l2x_Flrl_rofi_18O + integer :: index_l2x_Flrl_rofi_HDO + + integer :: index_x2l_Faxa_rainc_16O + integer :: index_x2l_Faxa_rainc_18O + integer :: index_x2l_Faxa_rainc_HDO + integer :: index_x2l_Faxa_rainl_16O + integer :: index_x2l_Faxa_rainl_18O + integer :: index_x2l_Faxa_rainl_HDO + integer :: index_x2l_Faxa_snowc_16O + integer :: index_x2l_Faxa_snowc_18O + integer :: index_x2l_Faxa_snowc_HDO + integer :: index_x2l_Faxa_snowl_16O + integer :: index_x2l_Faxa_snowl_18O + integer :: index_x2l_Faxa_snowl_HDO + integer :: index_x2l_Flrr_flood_16O + integer :: index_x2l_Flrr_flood_18O + integer :: index_x2l_Flrr_flood_HDO + + integer :: index_r2x_Forr_rofl_16O + integer :: index_r2x_Forr_rofl_18O + integer :: index_r2x_Forr_rofl_HDO + integer :: index_r2x_Forr_rofi_16O + integer :: index_r2x_Forr_rofi_18O + integer :: index_r2x_Forr_rofi_HDO + integer :: index_r2x_Flrr_flood_16O + integer :: index_r2x_Flrr_flood_18O + integer :: index_r2x_Flrr_flood_HDO + + integer :: index_x2r_Flrl_rofl_16O + integer :: index_x2r_Flrl_rofl_18O + integer :: index_x2r_Flrl_rofl_HDO + integer :: index_x2r_Flrl_rofi_16O + integer :: index_x2r_Flrl_rofi_18O + integer :: index_x2r_Flrl_rofi_HDO + + integer :: index_xao_Faox_evap_16O + integer :: index_xao_Faox_evap_18O + integer :: index_xao_Faox_evap_HDO + + integer :: index_x2o_Fioi_meltw_16O + integer :: index_x2o_Fioi_meltw_18O + integer :: index_x2o_Fioi_meltw_HDO + integer :: index_x2o_Faxa_rain_16O + integer :: index_x2o_Faxa_rain_18O + integer :: index_x2o_Faxa_rain_HDO + integer :: index_x2o_Faxa_snow_16O + integer :: index_x2o_Faxa_snow_18O + integer :: index_x2o_Faxa_snow_HDO + + integer :: index_i2x_Fioi_meltw_16O + integer :: index_i2x_Fioi_meltw_18O + integer :: index_i2x_Fioi_meltw_HDO + integer :: index_i2x_Faii_evap_16O + integer :: index_i2x_Faii_evap_18O + integer :: index_i2x_Faii_evap_HDO + + integer :: index_x2i_Faxa_rain_16O + integer :: index_x2i_Faxa_rain_18O + integer :: index_x2i_Faxa_rain_HDO + integer :: index_x2i_Faxa_snow_16O + integer :: index_x2i_Faxa_snow_18O + integer :: index_x2i_Faxa_snow_HDO + +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_zero_mct - zero out global budget diagnostic data. +! +! !DESCRIPTION: +! Zero out global budget diagnostic data. +! +! !REVISION HISTORY: +! 2008-jul-11 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_zero_mct(EClock,mode) + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(in),optional :: EClock + character(len=*), intent(in),optional :: mode + +!EOP + + integer(IN) :: ip,yr,mon,day,sec + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_zero_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (.not. present(EClock) .and. .not. present(mode)) then + call shr_sys_abort(subName//' ERROR EClock or mode should be present') + endif + + if (present(EClock)) then + call seq_timemgr_EClockGetData(EClock,curr_yr=yr, & + curr_mon=mon,curr_day=day,curr_tod=sec) + + do ip = 1,p_size + if (ip == p_inst) then + budg_dataL(:,:,ip) = 0.0_r8 + budg_dataG(:,:,ip) = 0.0_r8 + budg_ns(:,:,ip) = 0.0_r8 + endif + if (ip==p_day .and. sec==0) then + budg_dataL(:,:,ip) = 0.0_r8 + budg_dataG(:,:,ip) = 0.0_r8 + budg_ns(:,:,ip) = 0.0_r8 + endif + if (ip==p_mon .and. day==1 .and. sec==0) then + budg_dataL(:,:,ip) = 0.0_r8 + budg_dataG(:,:,ip) = 0.0_r8 + budg_ns(:,:,ip) = 0.0_r8 + endif + if (ip==p_ann .and. mon==1 .and. day==1 .and. sec==0) then + budg_dataL(:,:,ip) = 0.0_r8 + budg_dataG(:,:,ip) = 0.0_r8 + budg_ns(:,:,ip) = 0.0_r8 + endif + enddo + endif + + if (present(mode)) then + if (trim(mode) == 'inst') then + budg_dataL(:,:,p_inst) = 0.0_r8 + budg_dataG(:,:,p_inst) = 0.0_r8 + budg_ns(:,:,p_inst) = 0.0_r8 + elseif (trim(mode) == 'day') then + budg_dataL(:,:,p_day) = 0.0_r8 + budg_dataG(:,:,p_day) = 0.0_r8 + budg_ns(:,:,p_day) = 0.0_r8 + elseif (trim(mode) == 'mon') then + budg_dataL(:,:,p_mon) = 0.0_r8 + budg_dataG(:,:,p_mon) = 0.0_r8 + budg_ns(:,:,p_mon) = 0.0_r8 + elseif (trim(mode) == 'ann') then + budg_dataL(:,:,p_ann) = 0.0_r8 + budg_dataG(:,:,p_ann) = 0.0_r8 + budg_ns(:,:,p_ann) = 0.0_r8 + elseif (trim(mode) == 'inf') then + budg_dataL(:,:,p_inf) = 0.0_r8 + budg_dataG(:,:,p_inf) = 0.0_r8 + budg_ns(:,:,p_inf) = 0.0_r8 + elseif (trim(mode) == 'all') then + budg_dataL(:,:,:) = 0.0_r8 + budg_dataG(:,:,:) = 0.0_r8 + budg_ns(:,:,:) = 0.0_r8 + else + call shr_sys_abort(subname//' ERROR in mode '//trim(mode)) + endif + endif + +end subroutine seq_diag_zero_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_accum_mct - accum out global budget diagnostic data. +! +! !DESCRIPTION: +! Accum out global budget diagnostic data. +! +! !REVISION HISTORY: +! 2008-jul-11 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_accum_mct() + +! !INPUT/OUTPUT PARAMETERS: + +!EOP + + integer(in) :: ip + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_accum_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + do ip = p_inst+1,p_size + budg_dataL(:,:,ip) = budg_dataL(:,:,ip) + budg_dataL(:,:,p_inst) + enddo + budg_ns(:,:,:) = budg_ns(:,:,:) + 1.0_r8 + +end subroutine seq_diag_accum_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_sum0_mct - sum local to global on root +! +! !DESCRIPTION: +! Sum local values to global on root +! +! !REVISION HISTORY: +! 2008-jul-19 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_sum0_mct() + +! !INPUT/OUTPUT PARAMETERS: + +!EOP + + real(r8) :: budg_dataGtmp(f_size,c_size,p_size) ! temporary sum + integer(in) :: mpicom ! mpi comm + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_sum0_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID,mpicom=mpicom) + budg_dataGtmp = 0.0_r8 + call shr_mpi_sum(budg_dataL,budg_dataGtmp,mpicom,subName) + budg_dataG = budg_dataG + budg_dataGtmp + budg_dataL = 0.0_r8 + +end subroutine seq_diag_sum0_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_atm_mct - compute global atm input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global atm input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_atm_mct( atm, frac_a, infodata, do_a2x, do_x2a) + +! !INPUT/OUTPUT PARAMETERS: + + type(component_type) , intent(in) :: atm ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_a ! frac bundle + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in), optional :: do_a2x + logical , intent(in), optional :: do_x2a + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: a2x_a ! model to drv bundle + type(mct_aVect), pointer :: x2a_a ! drv to model bundle + type(mct_ggrid), pointer :: dom_a + integer(in) :: k,n,ic,if,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl ! area of a grid cell + logical,save :: first_time = .true. + logical,save :: flds_wiso_atm = .false. + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_atm_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + dom_a => component_get_dom_cx(atm) + a2x_a => component_get_c2x_cx(atm) + x2a_a => component_get_x2c_cx(atm) + + kArea = mct_aVect_indexRA(dom_a%data,afldname) + kLat = mct_aVect_indexRA(dom_a%data,latname) + ka = mct_aVect_indexRA(frac_a,afracname) + kl = mct_aVect_indexRA(frac_a,lfracname) + ko = mct_aVect_indexRA(frac_a,ofracname) + ki = mct_aVect_indexRA(frac_a,ifracname) + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + ip = p_inst + + if (present(do_a2x)) then + if (first_time) then + index_a2x_Faxa_swnet = mct_aVect_indexRA(a2x_a,'Faxa_swnet') + index_a2x_Faxa_lwdn = mct_aVect_indexRA(a2x_a,'Faxa_lwdn') + index_a2x_Faxa_rainc = mct_aVect_indexRA(a2x_a,'Faxa_rainc') + index_a2x_Faxa_rainl = mct_aVect_indexRA(a2x_a,'Faxa_rainl') + index_a2x_Faxa_snowc = mct_aVect_indexRA(a2x_a,'Faxa_snowc') + index_a2x_Faxa_snowl = mct_aVect_indexRA(a2x_a,'Faxa_snowl') + + index_a2x_Faxa_rainc_16O = mct_aVect_indexRA(a2x_a,'Faxa_rainc_16O',perrWith='quiet') + if ( index_a2x_Faxa_rainc_16O /= 0 ) flds_wiso_atm = .true. + if ( flds_wiso_atm )then + flds_wiso = .true. + index_a2x_Faxa_rainc_18O = mct_aVect_indexRA(a2x_a,'Faxa_rainc_18O') + index_a2x_Faxa_rainc_HDO = mct_aVect_indexRA(a2x_a,'Faxa_rainc_HDO') + index_a2x_Faxa_rainl_16O = mct_aVect_indexRA(a2x_a,'Faxa_rainl_16O') + index_a2x_Faxa_rainl_18O = mct_aVect_indexRA(a2x_a,'Faxa_rainl_18O') + index_a2x_Faxa_rainl_HDO = mct_aVect_indexRA(a2x_a,'Faxa_rainl_HDO') + index_a2x_Faxa_snowc_16O = mct_aVect_indexRA(a2x_a,'Faxa_snowc_16O') + index_a2x_Faxa_snowc_18O = mct_aVect_indexRA(a2x_a,'Faxa_snowc_18O') + index_a2x_Faxa_snowc_HDO = mct_aVect_indexRA(a2x_a,'Faxa_snowc_HDO') + index_a2x_Faxa_snowl_16O = mct_aVect_indexRA(a2x_a,'Faxa_snowl_16O') + index_a2x_Faxa_snowl_18O = mct_aVect_indexRA(a2x_a,'Faxa_snowl_18O') + index_a2x_Faxa_snowl_HDO = mct_aVect_indexRA(a2x_a,'Faxa_snowl_HDO') + end if + + end if + + lSize = mct_avect_lSize(a2x_a) + do n=1,lSize + do k=1,4 + + if (k == 1) then + ic = c_atm_ar + da = -dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ka,n) + elseif (k == 2) then + ic = c_lnd_ar + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(kl,n) + elseif (k == 3) then + ic = c_ocn_ar + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ko,n) + elseif (k == 4) then + if (dom_a%data%rAttr(kLat,n) > 0.0_r8) then + ic = c_inh_ar + else + ic = c_ish_ar + endif + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ki,n) + endif + + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da + if = f_hswnet; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*a2x_a%rAttr(index_a2x_Faxa_swnet,n) + if = f_hlwdn ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*a2x_a%rAttr(index_a2x_Faxa_lwdn,n) + if = f_wrain ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*a2x_a%rAttr(index_a2x_Faxa_rainc,n) & + + da*a2x_a%rAttr(index_a2x_Faxa_rainl,n) + if = f_wsnow ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*a2x_a%rAttr(index_a2x_Faxa_snowc,n) & + + da*a2x_a%rAttr(index_a2x_Faxa_snowl,n) + if ( flds_wiso_atm )then + if = f_wrain_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainc_16O,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainl_16O,n) + if = f_wrain_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainc_18O,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainl_18O,n) + if = f_wrain_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainc_HDO,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_rainl_HDO,n) + if = f_wsnow_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowc_16O,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowl_16O,n) + if = f_wsnow_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowc_18O,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowl_18O,n) + if = f_wsnow_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowc_HDO,n) + & + da*a2x_a%rAttr(index_a2x_Faxa_snowl_HDO,n) + end if + enddo + enddo + ! --- heat implied by snow flux --- + ic = c_atm_ar; budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + ic = c_lnd_ar; budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + ic = c_ocn_ar; budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + ic = c_inh_ar; budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + ic = c_ish_ar; budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + end if + + if (present(do_x2a)) then + if (first_time) then + index_x2a_Faxx_lwup = mct_aVect_indexRA(x2a_a,'Faxx_lwup') + index_x2a_Faxx_lat = mct_aVect_indexRA(x2a_a,'Faxx_lat') + index_x2a_Faxx_sen = mct_aVect_indexRA(x2a_a,'Faxx_sen') + index_x2a_Faxx_evap = mct_aVect_indexRA(x2a_a,'Faxx_evap') + + if ( flds_wiso_atm )then + index_x2a_Faxx_evap_16O = mct_aVect_indexRA(x2a_a,'Faxx_evap_16O') + index_x2a_Faxx_evap_18O = mct_aVect_indexRA(x2a_a,'Faxx_evap_18O') + index_x2a_Faxx_evap_HDO = mct_aVect_indexRA(x2a_a,'Faxx_evap_HDO') + end if + end if + + lSize = mct_avect_lSize(x2a_a) + do n=1,lSize + do k=1,4 + + if (k == 1) then + ic = c_atm_as + da = -dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ka,n) + elseif (k == 2) then + ic = c_lnd_as + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(kl,n) + elseif (k == 3) then + ic = c_ocn_as + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ko,n) + elseif (k == 4) then + if (dom_a%data%rAttr(kLat,n) > 0.0_r8) then + ic = c_inh_as + else + ic = c_ish_as + endif + da = dom_a%data%rAttr(kArea,n) * frac_a%rAttr(ki,n) + endif + + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da + if = f_hlwup; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*x2a_a%rAttr(index_x2a_Faxx_lwup,n) + if = f_hlatv; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*x2a_a%rAttr(index_x2a_Faxx_lat,n) + if = f_hsen ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*x2a_a%rAttr(index_x2a_Faxx_sen,n) + if = f_wevap; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + da*x2a_a%rAttr(index_x2a_Faxx_evap,n) + + if ( flds_wiso_atm )then + if = f_wevap_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*x2a_a%rAttr(index_x2a_Faxx_evap_16O,n) + if = f_wevap_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*x2a_a%rAttr(index_x2a_Faxx_evap_18O,n) + if = f_wevap_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + da*x2a_a%rAttr(index_x2a_Faxx_evap_HDO,n) + end if + + enddo + enddo + end if + + first_time = .false. + +end subroutine seq_diag_atm_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_lnd_mct - compute global lnd input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global lnd input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_lnd_mct( lnd, frac_l, infodata, do_l2x, do_x2l) + + type(component_type) , intent(in) :: lnd ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_l ! frac bundle + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in), optional :: do_l2x + logical , intent(in), optional :: do_x2l + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: l2x_l ! model to drv bundle + type(mct_aVect), pointer :: x2l_l ! drv to model bundle + type(mct_ggrid), pointer :: dom_l + integer(in) :: k,n,ic,if,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl ! area of a grid cell + logical,save :: first_time = .true. + logical,save :: flds_wiso_lnd = .false. + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_lnd_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + dom_l => component_get_dom_cx(lnd) + l2x_l => component_get_c2x_cx(lnd) + x2l_l => component_get_x2c_cx(lnd) + + ip = p_inst + + kArea = mct_aVect_indexRA(dom_l%data,afldname) + kl = mct_aVect_indexRA(frac_l,lfracname) + + if (present(do_l2x)) then + if (first_time) then + index_l2x_Fall_swnet = mct_aVect_indexRA(l2x_l,'Fall_swnet') + index_l2x_Fall_lwup = mct_aVect_indexRA(l2x_l,'Fall_lwup') + index_l2x_Fall_lat = mct_aVect_indexRA(l2x_l,'Fall_lat') + index_l2x_Fall_sen = mct_aVect_indexRA(l2x_l,'Fall_sen') + index_l2x_Fall_evap = mct_aVect_indexRA(l2x_l,'Fall_evap') + index_l2x_Flrl_rofsur = mct_aVect_indexRA(l2x_l,'Flrl_rofsur') + index_l2x_Flrl_rofgwl = mct_aVect_indexRA(l2x_l,'Flrl_rofgwl') + index_l2x_Flrl_rofsub = mct_aVect_indexRA(l2x_l,'Flrl_rofsub') + index_l2x_Flrl_rofdto = mct_aVect_indexRA(l2x_l,'Flrl_rofdto') + index_l2x_Flrl_rofi = mct_aVect_indexRA(l2x_l,'Flrl_rofi') + index_l2x_Flrl_irrig = mct_aVect_indexRA(l2x_l,'Flrl_irrig', perrWith='quiet') + + index_l2x_Fall_evap_16O = mct_aVect_indexRA(l2x_l,'Fall_evap_16O',perrWith='quiet') + if ( index_l2x_Fall_evap_16O /= 0 ) flds_wiso_lnd = .true. + if ( flds_wiso_lnd )then + flds_wiso = .true. + index_l2x_Fall_evap_18O = mct_aVect_indexRA(l2x_l,'Fall_evap_18O') + index_l2x_Fall_evap_HDO = mct_aVect_indexRA(l2x_l,'Fall_evap_HDO') + index_l2x_Flrl_rofl_16O = mct_aVect_indexRA(l2x_l,'Flrl_rofl_16O') + index_l2x_Flrl_rofl_18O = mct_aVect_indexRA(l2x_l,'Flrl_rofl_18O') + index_l2x_Flrl_rofl_HDO = mct_aVect_indexRA(l2x_l,'Flrl_rofl_HDO') + index_l2x_Flrl_rofi_16O = mct_aVect_indexRA(l2x_l,'Flrl_rofi_16O') + index_l2x_Flrl_rofi_18O = mct_aVect_indexRA(l2x_l,'Flrl_rofi_18O') + index_l2x_Flrl_rofi_HDO = mct_aVect_indexRA(l2x_l,'Flrl_rofi_HDO') + end if + end if + + lSize = mct_avect_lSize(l2x_l) + ic = c_lnd_lr + do n=1,lSize + dl = dom_l%data%rAttr(kArea,n) * frac_l%rAttr(kl,n) + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl + if = f_hswnet; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*l2x_l%rAttr(index_l2x_Fall_swnet,n) + if = f_hlwup ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*l2x_l%rAttr(index_l2x_Fall_lwup,n) + if = f_hlatv ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*l2x_l%rAttr(index_l2x_Fall_lat,n) + if = f_hsen ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*l2x_l%rAttr(index_l2x_Fall_sen,n) + if = f_wevap ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*l2x_l%rAttr(index_l2x_Fall_evap,n) + if = f_wroff ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dl*l2x_l%rAttr(index_l2x_Flrl_rofsur,n) & + - dl*l2x_l%rAttr(index_l2x_Flrl_rofgwl,n) & + - dl*l2x_l%rAttr(index_l2x_Flrl_rofsub,n) & + - dl*l2x_l%rAttr(index_l2x_Flrl_rofdto,n) + if (index_l2x_Flrl_irrig /= 0) then + if = f_wroff ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dl*l2x_l%rAttr(index_l2x_Flrl_irrig,n) + end if + if = f_wioff ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dl*l2x_l%rAttr(index_l2x_Flrl_rofi,n) + + if ( flds_wiso_lnd )then + if = f_wevap_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*l2x_l%rAttr(index_l2x_Fall_evap_16O,n) + if = f_wevap_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*l2x_l%rAttr(index_l2x_Fall_evap_18O,n) + if = f_wevap_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*l2x_l%rAttr(index_l2x_Fall_evap_HDO,n) + + if = f_wroff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofl_16O,n) + if = f_wroff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofl_18O,n) + if = f_wroff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofl_HDO,n) + + if = f_wioff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofi_16O,n) + if = f_wioff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofi_18O,n) + if = f_wioff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*l2x_l%rAttr(index_l2x_Flrl_rofi_HDO,n) + end if + end do + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + end if + + if (present(do_x2l)) then + if (first_time) then + index_x2l_Faxa_lwdn = mct_aVect_indexRA(x2l_l,'Faxa_lwdn') + index_x2l_Faxa_rainc = mct_aVect_indexRA(x2l_l,'Faxa_rainc') + index_x2l_Faxa_rainl = mct_aVect_indexRA(x2l_l,'Faxa_rainl') + index_x2l_Faxa_snowc = mct_aVect_indexRA(x2l_l,'Faxa_snowc') + index_x2l_Faxa_snowl = mct_aVect_indexRA(x2l_l,'Faxa_snowl') + index_x2l_Flrr_flood = mct_aVect_indexRA(x2l_l,'Flrr_flood') + + if ( flds_wiso_lnd )then + index_x2l_Faxa_rainc_16O = mct_aVect_indexRA(x2l_l,'Faxa_rainc_16O') + index_x2l_Faxa_rainc_18O = mct_aVect_indexRA(x2l_l,'Faxa_rainc_18O') + index_x2l_Faxa_rainc_HDO = mct_aVect_indexRA(x2l_l,'Faxa_rainc_HDO') + index_x2l_Faxa_rainl_16O = mct_aVect_indexRA(x2l_l,'Faxa_rainl_16O') + index_x2l_Faxa_rainl_18O = mct_aVect_indexRA(x2l_l,'Faxa_rainl_18O') + index_x2l_Faxa_rainl_HDO = mct_aVect_indexRA(x2l_l,'Faxa_rainl_HDO') + index_x2l_Faxa_snowc_16O = mct_aVect_indexRA(x2l_l,'Faxa_snowc_16O') + index_x2l_Faxa_snowc_18O = mct_aVect_indexRA(x2l_l,'Faxa_snowc_18O') + index_x2l_Faxa_snowc_HDO = mct_aVect_indexRA(x2l_l,'Faxa_snowc_HDO') + index_x2l_Faxa_snowl_16O = mct_aVect_indexRA(x2l_l,'Faxa_snowl_16O') + index_x2l_Faxa_snowl_18O = mct_aVect_indexRA(x2l_l,'Faxa_snowl_18O') + index_x2l_Faxa_snowl_HDO = mct_aVect_indexRA(x2l_l,'Faxa_snowl_HDO') + index_x2l_Flrr_flood_16O = mct_aVect_indexRA(x2l_l,'Flrr_flood_16O') + index_x2l_Flrr_flood_18O = mct_aVect_indexRA(x2l_l,'Flrr_flood_18O') + index_x2l_Flrr_flood_HDO = mct_aVect_indexRA(x2l_l,'Flrr_flood_HDO') + end if + end if + + lSize = mct_avect_lSize(x2l_l) + ic = c_lnd_ls + do n=1,lSize + dl = dom_l%data%rAttr(kArea,n) * frac_l%rAttr(kl,n) + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl + if = f_hlwdn; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*x2l_l%rAttr(index_x2l_Faxa_lwdn,n) + if = f_wrain; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*x2l_l%rAttr(index_x2l_Faxa_rainc,n) & + + dl*x2l_l%rAttr(index_x2l_Faxa_rainl,n) + if = f_wsnow; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dl*x2l_l%rAttr(index_x2l_Faxa_snowc,n) & + + dl*x2l_l%rAttr(index_x2l_Faxa_snowl,n) + if = f_wroff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dl*x2l_l%rAttr(index_x2l_Flrr_flood,n) + + if ( flds_wiso_lnd )then + if = f_wrain_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainc_16O,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainl_16O,n) + if = f_wrain_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainc_18O,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainl_18O,n) + if = f_wrain_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainc_HDO,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_rainl_HDO,n) + + if = f_wsnow_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowc_16O,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowl_16O,n) + if = f_wsnow_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowc_18O,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowl_18O,n) + if = f_wsnow_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowc_HDO,n) + & + dl*x2l_l%rAttr(index_x2l_Faxa_snowl_HDO,n) + + if = f_wroff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*x2l_l%rAttr(index_x2l_Flrr_flood_16O,n) + if = f_wroff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*x2l_l%rAttr(index_x2l_Flrr_flood_18O,n) + if = f_wroff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dl*x2l_l%rAttr(index_x2l_Flrr_flood_HDO,n) + end if + end do + budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + end if + + first_time = .false. + +end subroutine seq_diag_lnd_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_rof_mct - compute global rof input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global rof input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_rof_mct( rof, frac_r, infodata) + + type(component_type) , intent(in) :: rof ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_r ! frac bundle + type(seq_infodata_type) , intent(in) :: infodata + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: r2x_r + type(mct_aVect), pointer :: x2r_r + type(mct_ggrid), pointer :: dom_r + integer(in) :: k,n,ic,if,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki,kr ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl,dr ! area of a grid cell + logical,save :: first_time = .true. + logical,save :: flds_wiso_rof = .false. + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_rof_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + dom_r => component_get_dom_cx(rof) + r2x_r => component_get_c2x_cx(rof) + x2r_r => component_get_x2c_cx(rof) + + if (first_time) then + index_x2r_Flrl_rofsur = mct_aVect_indexRA(x2r_r,'Flrl_rofsur') + index_x2r_Flrl_rofgwl = mct_aVect_indexRA(x2r_r,'Flrl_rofgwl') + index_x2r_Flrl_rofsub = mct_aVect_indexRA(x2r_r,'Flrl_rofsub') + index_x2r_Flrl_rofdto = mct_aVect_indexRA(x2r_r,'Flrl_rofdto') + index_x2r_Flrl_irrig = mct_aVect_indexRA(x2r_r,'Flrl_irrig', perrWith='quiet') + index_x2r_Flrl_rofi = mct_aVect_indexRA(x2r_r,'Flrl_rofi') + + index_x2r_Flrl_rofl_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofl_16O', perrWith='quiet') + if ( index_x2r_Flrl_rofl_16O /= 0 ) flds_wiso_rof = .true. + if ( flds_wiso_rof )then + flds_wiso = .true. + index_x2r_Flrl_rofl_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofl_18O') + index_x2r_Flrl_rofl_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofl_HDO') + index_x2r_Flrl_rofi_16O = mct_aVect_indexRA(x2r_r,'Flrl_rofi_16O') + index_x2r_Flrl_rofi_18O = mct_aVect_indexRA(x2r_r,'Flrl_rofi_18O') + index_x2r_Flrl_rofi_HDO = mct_aVect_indexRA(x2r_r,'Flrl_rofi_HDO') + end if + end if + + ip = p_inst + ic = c_rof_rr + kArea = mct_aVect_indexRA(dom_r%data,afldname) + lSize = mct_avect_lSize(x2r_r) + do n=1,lSize + dr = dom_r%data%rAttr(kArea,n) + if = f_wroff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dr*x2r_r%rAttr(index_x2r_Flrl_rofsur,n) & + + dr*x2r_r%rAttr(index_x2r_Flrl_rofgwl,n) & + + dr*x2r_r%rAttr(index_x2r_Flrl_rofsub,n) & + + dr*x2r_r%rAttr(index_x2r_Flrl_rofdto,n) + if (index_x2r_Flrl_irrig /= 0) then + if = f_wroff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dr*x2r_r%rAttr(index_x2r_Flrl_irrig,n) + end if + + if = f_wioff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + dr*x2r_r%rAttr(index_x2r_Flrl_rofi,n) + + if ( flds_wiso_rof )then + if = f_wroff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofl_16O,n) + if = f_wroff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofl_18O,n) + if = f_wroff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofl_HDO,n) + + if = f_wioff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofi_16O,n) + if = f_wioff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofi_18O,n) + if = f_wioff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*x2r_r%rAttr(index_x2r_Flrl_rofi_HDO,n) + end if + end do + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + + if (first_time) then + index_r2x_Forr_rofl = mct_aVect_indexRA(r2x_r,'Forr_rofl') + index_r2x_Forr_rofi = mct_aVect_indexRA(r2x_r,'Forr_rofi') + index_r2x_Firr_rofi = mct_aVect_indexRA(r2x_r,'Firr_rofi') + index_r2x_Flrr_flood = mct_aVect_indexRA(r2x_r,'Flrr_flood') + + if ( flds_wiso_rof )then + index_r2x_Forr_rofl_16O = mct_aVect_indexRA(r2x_r,'Forr_rofl_16O') + index_r2x_Forr_rofl_18O = mct_aVect_indexRA(r2x_r,'Forr_rofl_18O') + index_r2x_Forr_rofl_HDO = mct_aVect_indexRA(r2x_r,'Forr_rofl_HDO') + index_r2x_Forr_rofi_16O = mct_aVect_indexRA(r2x_r,'Forr_rofi_16O') + index_r2x_Forr_rofi_18O = mct_aVect_indexRA(r2x_r,'Forr_rofi_18O') + index_r2x_Forr_rofi_HDO = mct_aVect_indexRA(r2x_r,'Forr_rofi_HDO') + index_r2x_Flrr_flood_16O = mct_aVect_indexRA(r2x_r,'Flrr_flood_16O') + index_r2x_Flrr_flood_18O = mct_aVect_indexRA(r2x_r,'Flrr_flood_18O') + index_r2x_Flrr_flood_HDO = mct_aVect_indexRA(r2x_r,'Flrr_flood_HDO') + end if + end if + + ip = p_inst + ic = c_rof_rs + kArea = mct_aVect_indexRA(dom_r%data,afldname) + lSize = mct_avect_lSize(r2x_r) + do n=1,lSize + dr = dom_r%data%rAttr(kArea,n) + if = f_wroff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dr*r2x_r%rAttr(index_r2x_Forr_rofl,n) & + + dr*r2x_r%rAttr(index_r2x_Flrr_flood,n) + if = f_wioff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dr*r2x_r%rAttr(index_r2x_Forr_rofi,n) & + - dr*r2x_r%rAttr(index_r2x_Firr_rofi,n) + + if ( flds_wiso_rof )then + if = f_wroff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofl_16O,n) + if = f_wroff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofl_18O,n) + if = f_wroff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofl_HDO,n) + + if = f_wioff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofi_16O,n) + if = f_wioff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofi_18O,n) + if = f_wioff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + dr*r2x_r%rAttr(index_r2x_Forr_rofi_HDO,n) + + if = f_wroff_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*r2x_r%rAttr(index_r2x_Flrr_flood_16O,n) + if = f_wroff_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*r2x_r%rAttr(index_r2x_Flrr_flood_18O,n) + if = f_wroff_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + dr*r2x_r%rAttr(index_r2x_Flrr_flood_HDO,n) + end if + end do + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + + first_time = .false. + +end subroutine seq_diag_rof_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_glc_mct - compute global glc input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global glc input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_glc_mct( glc, frac_g, infodata) + + type(component_type) , intent(in) :: glc ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_g ! frac bundle + type(seq_infodata_type) , intent(in) :: infodata + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: g2x_g + type(mct_aVect), pointer :: x2g_g + type(mct_ggrid), pointer :: dom_g + integer(in) :: k,n,ic,if,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki,kr,kg ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl,dr,dg ! area of a grid cell + logical,save :: first_time = .true. + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_glc_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + dom_g => component_get_dom_cx(glc) + g2x_g => component_get_c2x_cx(glc) + x2g_g => component_get_x2c_cx(glc) + + if (first_time) then + index_g2x_Fogg_rofl = mct_aVect_indexRA(g2x_g,'Fogg_rofl') + index_g2x_Fogg_rofi = mct_aVect_indexRA(g2x_g,'Fogg_rofi') + index_g2x_Figg_rofi = mct_aVect_indexRA(g2x_g,'Figg_rofi') + end if + + ip = p_inst + ic = c_glc_gs + kArea = mct_aVect_indexRA(dom_g%data,afldname) + lSize = mct_avect_lSize(g2x_g) + do n=1,lSize + dg = dom_g%data%rAttr(kArea,n) + if = f_wroff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dg*g2x_g%rAttr(index_g2x_Fogg_rofl,n) + if = f_wioff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - dg*g2x_g%rAttr(index_g2x_Fogg_rofi,n) & + - dg*g2x_g%rAttr(index_g2x_Figg_rofi,n) + end do + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + + first_time = .false. + +end subroutine seq_diag_glc_mct + +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_ocn_mct - compute global ocn input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global ocn input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_ocn_mct( ocn, xao_o, frac_o, infodata, do_o2x, do_x2o, do_xao) + + type(component_type) , intent(in) :: ocn ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_o ! frac bundle + type(mct_aVect) , intent(in) :: xao_o + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in),optional :: do_o2x + logical , intent(in),optional :: do_x2o + logical , intent(in),optional :: do_xao + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: o2x_o ! model to drv bundle + type(mct_aVect), pointer :: x2o_o ! drv to model bundle + type(mct_ggrid), pointer :: dom_o + integer(in) :: k,n,if,ic,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl ! area of a grid cell + logical,save :: first_time = .true. + logical,save :: flds_wiso_ocn = .false. + character(len=cs) :: cime_model + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_ocn_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (.not. present(do_o2x) .and. & + .not. present(do_x2o) .and. & + .not. present(do_xao)) then + call shr_sys_abort(subName//"ERROR: must input a bundle") + end if + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + dom_o => component_get_dom_cx(ocn) + o2x_o => component_get_c2x_cx(ocn) + x2o_o => component_get_x2c_cx(ocn) + + ip = p_inst + + kArea = mct_aVect_indexRA(dom_o%data,afldname) + ko = mct_aVect_indexRA(frac_o,ofracname) + ki = mct_aVect_indexRA(frac_o,ifracname) + + call seq_infodata_GetData(infodata, cime_model=cime_model) + + if (present(do_o2x)) then + if (first_time) then + if (trim(cime_model) == 'acme') then + index_o2x_Fioo_frazil = mct_aVect_indexRA(o2x_o,'Fioo_frazil') + else if (trim(cime_model) == 'cesm') then + index_o2x_Fioo_q = mct_aVect_indexRA(o2x_o,'Fioo_q') + end if + end if + + lSize = mct_avect_lSize(o2x_o) + ic = c_ocn_or + do n=1,lSize + do = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ko,n) + di = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ki,n) + if = f_area; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do + if (trim(cime_model) == 'acme') then + if = f_wfrz; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - (do+di)*max(0.0_r8,o2x_o%rAttr(index_o2x_Fioo_frazil,n)) + else if (trim(cime_model) == 'cesm') then + if = f_hfrz; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*max(0.0_r8,o2x_o%rAttr(index_o2x_Fioo_q,n)) + end if + end do + if (trim(cime_model) == 'acme') then + budg_dataL(f_hfrz,ic,ip) = -budg_dataL(f_wfrz,ic,ip) * shr_const_latice + else if (trim(cime_model) == 'cesm') then + budg_dataL(f_wfrz,ic,ip) = budg_dataL(f_hfrz,ic,ip) * HFLXtoWFLX + end if + end if + + if (present(do_xao)) then + if (first_time) then + index_xao_Faox_lwup = mct_aVect_indexRA(xao_o,'Faox_lwup') + index_xao_Faox_lat = mct_aVect_indexRA(xao_o,'Faox_lat') + index_xao_Faox_sen = mct_aVect_indexRA(xao_o,'Faox_sen') + index_xao_Faox_evap = mct_aVect_indexRA(xao_o,'Faox_evap') + + index_xao_Faox_evap_16O = mct_aVect_indexRA(xao_o,'Faox_evap_16O',perrWith='quiet') + if ( index_xao_Faox_evap_16O /= 0 ) flds_wiso_ocn = .true. + if ( flds_wiso_ocn )then + flds_wiso = .true. + index_xao_Faox_evap_18O = mct_aVect_indexRA(xao_o,'Faox_evap_18O') + index_xao_Faox_evap_HDO = mct_aVect_indexRA(xao_o,'Faox_evap_HDO') + end if + end if + + lSize = mct_avect_lSize(xao_o) + ic = c_ocn_or + do n=1,lSize + do = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ko,n) + if = f_hlwup; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do*xao_o%rAttr(index_xao_Faox_lwup,n) + if = f_hlatv; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do*xao_o%rAttr(index_xao_Faox_lat,n) + if = f_hsen ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do*xao_o%rAttr(index_xao_Faox_sen,n) + if = f_wevap; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do*xao_o%rAttr(index_xao_Faox_evap,n) + + if ( flds_wiso_ocn )then + if = f_wevap_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + do*xao_o%rAttr(index_xao_Faox_evap_16O,n) + if = f_wevap_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + do*xao_o%rAttr(index_xao_Faox_evap_18O,n) + if = f_wevap_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + do*xao_o%rAttr(index_xao_Faox_evap_HDO,n) + end if + + end do + end if + + if (present(do_x2o)) then + if (first_time) then + index_x2o_Fioi_melth = mct_aVect_indexRA(x2o_o,'Fioi_melth') + index_x2o_Fioi_meltw = mct_aVect_indexRA(x2o_o,'Fioi_meltw') + index_x2o_Fioi_salt = mct_aVect_indexRA(x2o_o,'Fioi_salt') + index_x2o_Foxx_swnet = mct_aVect_indexRA(x2o_o,'Foxx_swnet') + index_x2o_Faxa_lwdn = mct_aVect_indexRA(x2o_o,'Faxa_lwdn') + index_x2o_Faxa_rain = mct_aVect_indexRA(x2o_o,'Faxa_rain') + index_x2o_Faxa_snow = mct_aVect_indexRA(x2o_o,'Faxa_snow') + index_x2o_Foxx_lwup = mct_aVect_indexRA(x2o_o,'Foxx_lwup') + index_x2o_Foxx_lat = mct_aVect_indexRA(x2o_o,'Foxx_lat') + index_x2o_Foxx_sen = mct_aVect_indexRA(x2o_o,'Foxx_sen') + index_x2o_Foxx_evap = mct_aVect_indexRA(x2o_o,'Foxx_evap') + index_x2o_Foxx_rofl = mct_aVect_indexRA(x2o_o,'Foxx_rofl') + index_x2o_Foxx_rofi = mct_aVect_indexRA(x2o_o,'Foxx_rofi') + + if ( flds_wiso_ocn )then + index_x2o_Fioi_meltw_16O = mct_aVect_indexRA(x2o_o,'Fioi_meltw_16O') + index_x2o_Fioi_meltw_18O = mct_aVect_indexRA(x2o_o,'Fioi_meltw_18O') + index_x2o_Fioi_meltw_HDO = mct_aVect_indexRA(x2o_o,'Fioi_meltw_HDO') + index_x2o_Faxa_rain_16O = mct_aVect_indexRA(x2o_o,'Faxa_rain_16O') + index_x2o_Faxa_rain_18O = mct_aVect_indexRA(x2o_o,'Faxa_rain_18O') + index_x2o_Faxa_rain_HDO = mct_aVect_indexRA(x2o_o,'Faxa_rain_HDO') + index_x2o_Faxa_snow_16O = mct_aVect_indexRA(x2o_o,'Faxa_snow_16O') + index_x2o_Faxa_snow_18O = mct_aVect_indexRA(x2o_o,'Faxa_snow_18O') + index_x2o_Faxa_snow_HDO = mct_aVect_indexRA(x2o_o,'Faxa_snow_HDO') + + index_x2o_Foxx_rofl_16O = mct_aVect_indexRA(x2o_o,'Foxx_rofl_16O') + index_x2o_Foxx_rofi_16O = mct_aVect_indexRA(x2o_o,'Foxx_rofi_16O') + index_x2o_Foxx_rofl_18O = mct_aVect_indexRA(x2o_o,'Foxx_rofl_18O') + index_x2o_Foxx_rofi_18O = mct_aVect_indexRA(x2o_o,'Foxx_rofi_18O') + index_x2o_Foxx_rofl_HDO = mct_aVect_indexRA(x2o_o,'Foxx_rofl_HDO') + index_x2o_Foxx_rofi_HDO = mct_aVect_indexRA(x2o_o,'Foxx_rofi_HDO') + end if + end if + + if (.not. present(do_xao)) then + ! these are in x2o but they really are the atm/ocean flux + ! computed in the coupler and are "like" an o2x + lSize = mct_avect_lSize(x2o_o) + ic = c_ocn_or + do n=1,lSize + do = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ko,n) + di = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ki,n) + if = f_hlwup; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_lwup,n) + if = f_hlatv; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_lat,n) + if = f_hsen ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_sen,n) + if = f_wevap; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_evap,n) + end do + endif + + lSize = mct_avect_lSize(x2o_o) + ic = c_ocn_os + do n=1,lSize + do = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ko,n) + di = dom_o%data%rAttr(kArea,n) * frac_o%rAttr(ki,n) + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + do + if = f_wmelt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Fioi_meltw,n) + if = f_hmelt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Fioi_melth,n) + if = f_wsalt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Fioi_salt,n) * SFLXtoWFLX + if = f_hswnet; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_swnet,n) + if = f_hlwdn ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Faxa_lwdn,n) + if = f_wrain ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Faxa_rain,n) + if = f_wsnow ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Faxa_snow,n) + if = f_wroff ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofl,n) + if = f_wioff ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofi,n) + + if ( flds_wiso_ocn )then + if = f_wmelt_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Fioi_meltw_16O,n) + if = f_wmelt_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Fioi_meltw_18O,n) + if = f_wmelt_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Fioi_meltw_HDO,n) + + if = f_wrain_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_rain_16O,n) + if = f_wrain_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_rain_18O,n) + if = f_wrain_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_rain_HDO,n) + + if = f_wsnow_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_snow_16O,n) + if = f_wsnow_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_snow_18O,n) + if = f_wsnow_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + (do+di)*x2o_o%rAttr(index_x2o_Faxa_snow_HDO,n) + if = f_wroff_16O ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofl_16O,n) + if = f_wioff_16O ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofi_16O,n) + if = f_wroff_18O ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofl_18O,n) + if = f_wioff_18O ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofi_18O,n) + if = f_wroff_HDO ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofl_HDO,n) + if = f_wioff_HDO ; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*x2o_o%rAttr(index_x2o_Foxx_rofi_HDO,n) + end if + end do + budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + end if + + ! EBK -- isotope r2x_Forr_rofl/i? + + first_time = .false. + +end subroutine seq_diag_ocn_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_ice_mct - compute global ice input/output flux diagnostics +! +! !DESCRIPTION: +! Compute global ice input/output flux diagnostics +! +! !REVISION HISTORY: +! 2008-jul-10 - T. Craig - update +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_diag_ice_mct( ice, frac_i, infodata, do_i2x, do_x2i) + + type(component_type) , intent(in) :: ice ! component type for instance1 + type(mct_aVect) , intent(in) :: frac_i ! frac bundle + type(seq_infodata_type) , intent(in) :: infodata + logical , intent(in), optional :: do_i2x + logical , intent(in), optional :: do_x2i + +!EOP + + !----- local ----- + type(mct_aVect), pointer :: i2x_i ! model to drv bundle + type(mct_aVect), pointer :: x2i_i ! drv to model bundle + type(mct_ggrid), pointer :: dom_i + integer(in) :: k,n,ic,if,ip ! generic index + integer(in) :: kArea ! index of area field in aVect + integer(in) :: kLat ! index of lat field in aVect + integer(in) :: kl,ka,ko,ki ! fraction indices + integer(in) :: lSize ! size of aVect + real(r8) :: da,di,do,dl ! area of a grid cell + logical,save :: first_time = .true. + logical,save :: flds_wiso_ice = .false. + logical,save :: flds_wiso_ice_x2i = .false. + character(len=cs) :: cime_model + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_ice_mct) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call seq_infodata_GetData(infodata, cime_model=cime_model) + + !--------------------------------------------------------------------------- + ! add values found in this bundle to the budget table + !--------------------------------------------------------------------------- + + dom_i => component_get_dom_cx(ice) + i2x_i => component_get_c2x_cx(ice) + x2i_i => component_get_x2c_cx(ice) + + ip = p_inst + + kArea = mct_aVect_indexRA(dom_i%data,afldname) + kLat = mct_aVect_indexRA(dom_i%data,latname) + ki = mct_aVect_indexRA(frac_i,ifracname) + ko = mct_aVect_indexRA(frac_i,ofracname) + + if (present(do_i2x)) then + index_i2x_Fioi_melth = mct_aVect_indexRA(i2x_i,'Fioi_melth') + index_i2x_Fioi_meltw = mct_aVect_indexRA(i2x_i,'Fioi_meltw') + index_i2x_Fioi_swpen = mct_aVect_indexRA(i2x_i,'Fioi_swpen') + index_i2x_Faii_swnet = mct_aVect_indexRA(i2x_i,'Faii_swnet') + index_i2x_Faii_lwup = mct_aVect_indexRA(i2x_i,'Faii_lwup') + index_i2x_Faii_lat = mct_aVect_indexRA(i2x_i,'Faii_lat') + index_i2x_Faii_sen = mct_aVect_indexRA(i2x_i,'Faii_sen') + index_i2x_Faii_evap = mct_aVect_indexRA(i2x_i,'Faii_evap') + index_i2x_Fioi_salt = mct_aVect_indexRA(i2x_i,'Fioi_salt') + + index_i2x_Fioi_meltw_16O = mct_aVect_indexRA(i2x_i,'Fioi_meltw_16O',perrWith='quiet') + if ( index_i2x_Fioi_meltw_16O /= 0 ) flds_wiso_ice = .true. + if ( flds_wiso_ice )then + flds_wiso = .true. + index_i2x_Fioi_meltw_18O = mct_aVect_indexRA(i2x_i,'Fioi_meltw_18O') + index_i2x_Fioi_meltw_HDO = mct_aVect_indexRA(i2x_i,'Fioi_meltw_HDO') + index_i2x_Faii_evap_16O = mct_aVect_indexRA(i2x_i,'Faii_evap_16O') + index_i2x_Faii_evap_18O = mct_aVect_indexRA(i2x_i,'Faii_evap_18O') + index_i2x_Faii_evap_HDO = mct_aVect_indexRA(i2x_i,'Faii_evap_HDO') + end if + + lSize = mct_avect_lSize(i2x_i) + do n=1,lSize + if (dom_i%data%rAttr(kLat,n) > 0.0_r8) then + ic = c_inh_ir + else + ic = c_ish_ir + endif + do = dom_i%data%rAttr(kArea,n) * frac_i%rAttr(ko,n) + di = dom_i%data%rAttr(kArea,n) * frac_i%rAttr(ki,n) + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di + if = f_hmelt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - di*i2x_i%rAttr(index_i2x_Fioi_melth,n) + if = f_wmelt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - di*i2x_i%rAttr(index_i2x_Fioi_meltw,n) + if = f_wsalt ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - di*i2x_i%rAttr(index_i2x_Fioi_salt,n) * SFLXtoWFLX + if = f_hswnet; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*i2x_i%rAttr(index_i2x_Faii_swnet,n) & + - di*i2x_i%rAttr(index_i2x_Fioi_swpen,n) + if = f_hlwup ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*i2x_i%rAttr(index_i2x_Faii_lwup,n) + if = f_hlatv ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*i2x_i%rAttr(index_i2x_Faii_lat,n) + if = f_hsen ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*i2x_i%rAttr(index_i2x_Faii_sen,n) + if = f_wevap ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*i2x_i%rAttr(index_i2x_Faii_evap,n) + + if ( flds_wiso_ice )then + if = f_wmelt_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + di*i2x_i%rAttr(index_i2x_Fioi_meltw_16O,n) + if = f_wmelt_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + di*i2x_i%rAttr(index_i2x_Fioi_meltw_18O,n) + if = f_wmelt_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - & + di*i2x_i%rAttr(index_i2x_Fioi_meltw_HDO,n) + + if = f_wevap_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*i2x_i%rAttr(index_i2x_Faii_evap_16O,n) + if = f_wevap_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*i2x_i%rAttr(index_i2x_Faii_evap_18O,n) + if = f_wevap_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*i2x_i%rAttr(index_i2x_Faii_evap_HDO,n) + end if + end do + end if + + if (present(do_x2i)) then + if (first_time) then + index_x2i_Faxa_lwdn = mct_aVect_indexRA(x2i_i,'Faxa_lwdn') + index_x2i_Faxa_rain = mct_aVect_indexRA(x2i_i,'Faxa_rain') + index_x2i_Faxa_snow = mct_aVect_indexRA(x2i_i,'Faxa_snow') + if (trim(cime_model) == 'acme') then + index_x2i_Fioo_frazil = mct_aVect_indexRA(x2i_i,'Fioo_frazil') + else if (trim(cime_model) == 'cesm') then + index_x2i_Fioo_q = mct_aVect_indexRA(x2i_i,'Fioo_q') + end if + index_x2i_Fixx_rofi = mct_aVect_indexRA(x2i_i,'Fixx_rofi') + + index_x2i_Faxa_rain_16O = mct_aVect_indexRA(x2i_i,'Faxa_rain_16O', perrWith='quiet') + if ( index_x2i_Faxa_rain_16O /= 0 ) flds_wiso_ice_x2i = .true. + if ( flds_wiso_ice_x2i )then + flds_wiso = .true. + index_x2i_Faxa_rain_18O = mct_aVect_indexRA(x2i_i,'Faxa_rain_18O') + index_x2i_Faxa_rain_HDO = mct_aVect_indexRA(x2i_i,'Faxa_rain_HDO') + index_x2i_Faxa_snow_16O = mct_aVect_indexRA(x2i_i,'Faxa_snow_16O') + index_x2i_Faxa_snow_18O = mct_aVect_indexRA(x2i_i,'Faxa_snow_18O') + index_x2i_Faxa_snow_HDO = mct_aVect_indexRA(x2i_i,'Faxa_snow_HDO') + end if + end if + + lSize = mct_avect_lSize(x2i_i) + do n=1,lSize + if (dom_i%data%rAttr(kLat,n) > 0.0_r8) then + ic = c_inh_is + else + ic = c_ish_is + endif + do = dom_i%data%rAttr(kArea,n) * frac_i%rAttr(ko,n) + di = dom_i%data%rAttr(kArea,n) * frac_i%rAttr(ki,n) + if = f_area ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di + if = f_hlwdn; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*x2i_i%rAttr(index_x2i_Faxa_lwdn,n) + if = f_wrain; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*x2i_i%rAttr(index_x2i_Faxa_rain,n) + if = f_wsnow; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*x2i_i%rAttr(index_x2i_Faxa_snow,n) + if = f_wioff; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + di*x2i_i%rAttr(index_x2i_Fixx_rofi,n) + + if (trim(cime_model) == 'acme') then + if = f_wfrz ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + (do+di)*max(0.0_r8,x2i_i%rAttr(index_x2i_Fioo_frazil,n)) + else if (trim(cime_model) == 'cesm') then + if = f_hfrz ; budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) - (do+di)*max(0.0_r8,x2i_i%rAttr(index_x2i_Fioo_q,n)) + end if + if ( flds_wiso_ice_x2i )then + if = f_wrain_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_rain_16O,n) + if = f_wrain_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_rain_18O,n) + if = f_wrain_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_rain_HDO,n) + + if = f_wsnow_16O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_snow_16O,n) + if = f_wsnow_18O; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_snow_18O,n) + if = f_wsnow_HDO; + budg_dataL(if,ic,ip) = budg_dataL(if,ic,ip) + & + di*x2i_i%rAttr(index_x2i_Faxa_snow_HDO,n) + end if + end do + ic = c_inh_is + budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + if (trim(cime_model) == 'acme') then + budg_dataL(f_hfrz ,ic,ip) = -budg_dataL(f_wfrz ,ic,ip)*shr_const_latice + else if (trim(cime_model) == 'cesm') then + budg_dataL(f_wfrz ,ic,ip) = budg_dataL(f_hfrz ,ic,ip)*HFLXtoWFLX + end if + + ic = c_ish_is + budg_dataL(f_hlatf,ic,ip) = -budg_dataL(f_wsnow,ic,ip)*shr_const_latice + budg_dataL(f_hioff,ic,ip) = -budg_dataL(f_wioff,ic,ip)*shr_const_latice + if (trim(cime_model) == 'acme') then + budg_dataL(f_hfrz ,ic,ip) = -budg_dataL(f_wfrz ,ic,ip)*shr_const_latice + else if (trim(cime_model) == 'cesm') then + budg_dataL(f_wfrz ,ic,ip) = budg_dataL(f_hfrz ,ic,ip)*HFLXtoWFLX + end if + end if + + first_time = .false. + +end subroutine seq_diag_ice_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_print_mct - print global budget diagnostics +! +! !DESCRIPTION: +! Print global budget diagnostics. +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_diag_print_mct(EClock, stop_alarm, & + budg_print_inst, budg_print_daily, budg_print_month, & + budg_print_ann, budg_print_ltann, budg_print_ltend) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + logical , intent(in) :: stop_alarm + integer , intent(in) :: budg_print_inst + integer , intent(in) :: budg_print_daily + integer , intent(in) :: budg_print_month + integer , intent(in) :: budg_print_ann + integer , intent(in) :: budg_print_ltann + integer , intent(in) :: budg_print_ltend + +!EOP + + !--- local --- + integer(in) :: ic,if,ip,is ! data array indicies + integer(in) :: ica,icl,icn,ics,ico + integer(in) :: icar,icxs,icxr,icas + integer(in) :: n ! loop counter + integer(in) :: nday ! number of days in time avg + integer(in) :: cdate,sec ! coded date, seconds + integer(in) :: yr,mon,day ! date + integer(in) :: iam ! pe number + integer(in) :: plev ! print level + logical :: sumdone ! has a sum been computed yet + character(len=40):: str ! string + real(r8) :: dataGpr (f_size,c_size,p_size) ! values to print, scaled and such + integer, parameter :: nisotopes = 3 + character(len=5), parameter :: isoname(nisotopes) = (/ 'H216O', 'H218O', ' HDO' /) + integer, parameter :: iso0(nisotopes) = (/ f_16O, f_18O, f_hdO /) + integer, parameter :: isof(nisotopes) = (/ f_16O_end, f_18O_end, f_hdO_end /) + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_print_mct) ' + character(*),parameter :: F00 = "('(seq_diag_print_mct) ',4a)" + + !----- formats ----- + character(*),parameter :: FAH="(4a,i9,i6)" + character(*),parameter :: FA0= "(' ',12x,6(6x,a8,1x))" + character(*),parameter :: FA1= "(' ',a12,6f15.8)" + character(*),parameter :: FA0r="(' ',12x,8(6x,a8,1x))" + character(*),parameter :: FA1r="(' ',a12,8f15.8)" + +!------------------------------------------------------------------------------- +! print instantaneous budget data +!------------------------------------------------------------------------------- + + sumdone = .false. + call seq_comm_setptrs(CPLID,iam=iam) + call seq_timemgr_EClockGetData(EClock,curr_yr=yr, & + curr_mon=mon,curr_day=day,curr_tod=sec) + cdate = yr*10000+mon*100+day + + do ip = 1,p_size + plev = 0 + if (ip == p_inst) then + plev = max(plev,budg_print_inst) + endif + if (ip==p_day .and. sec==0) then + plev = max(plev,budg_print_daily) + endif + if (ip==p_mon .and. day==1 .and. sec==0) then + plev = max(plev,budg_print_month) + endif + if (ip==p_ann .and. mon==1 .and. day==1 .and. sec==0) then + plev = max(plev,budg_print_ann) + endif + if (ip==p_inf .and. mon==1 .and. day==1 .and. sec==0) then + plev = max(plev,budg_print_ltann) + endif + if (ip==p_inf .and. stop_alarm) then + plev = max(plev,budg_print_ltend) + endif + + if (plev > 0) then +! ---- doprint ---- doprint ---- doprint ---- + + if (.not.sumdone) then + call seq_diag_sum0_mct() + dataGpr = budg_dataG + sumdone = .true. + + ! old budget normalizations (global area and 1e6 for water) + dataGpr = dataGpr/(4.0_r8*shr_const_pi) + dataGpr(f_w:f_w_end,:,:) = dataGpr(f_w:f_w_end,:,:) * 1.0e6_r8 + if ( flds_wiso )then + dataGpr(iso0(1):isof(nisotopes),:,:) = dataGpr(iso0(1):isof(nisotopes),:,:) * 1.0e6_r8 + end if + dataGpr = dataGpr/budg_ns + + if (iam /= 0) return + endif + + ! --------------------------------------------------------- + ! ---- detail atm budgets and breakdown into components --- + ! --------------------------------------------------------- + + if (plev >= 3) then + do ic = 1,2 + if (ic == 1) then + ica = c_atm_ar + icl = c_lnd_ar + icn = c_inh_ar + ics = c_ish_ar + ico = c_ocn_ar + str = "ATM_to_CPL" + elseif (ic == 2) then + ica = c_atm_as + icl = c_lnd_as + icn = c_inh_as + ics = c_ish_as + ico = c_ocn_as + str = "CPL_TO_ATM" + else + call shr_sys_abort(subname//' ERROR in ic index code 411') + endif + + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' AREA BUDGET (m2/m2): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(ica),cname(icl),cname(icn),cname(ics),cname(ico),' *SUM* ' + do if = f_a, f_a_end + write(logunit,FA1) fname(if),dataGpr(if,ica,ip),dataGpr(if,icl,ip), & + dataGpr(if,icn,ip),dataGpr(if,ics,ip),dataGpr(if,ico,ip), & + dataGpr(if,ica,ip)+dataGpr(if,icl,ip)+ & + dataGpr(if,icn,ip)+dataGpr(if,ics,ip)+dataGpr(if,ico,ip) + enddo + + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(ica),cname(icl),cname(icn),cname(ics),cname(ico),' *SUM* ' + do if = f_h, f_h_end + write(logunit,FA1) fname(if),dataGpr(if,ica,ip),dataGpr(if,icl,ip), & + dataGpr(if,icn,ip),dataGpr(if,ics,ip),dataGpr(if,ico,ip), & + dataGpr(if,ica,ip)+dataGpr(if,icl,ip)+ & + dataGpr(if,icn,ip)+dataGpr(if,ics,ip)+dataGpr(if,ico,ip) + enddo + write(logunit,FA1) ' *SUM*' ,sum(dataGpr(f_h:f_h_end,ica,ip)),sum(dataGpr(f_h:f_h_end,icl,ip)), & + sum(dataGpr(f_h:f_h_end,icn,ip)),sum(dataGpr(f_h:f_h_end,ics,ip)),sum(dataGpr(f_h:f_h_end,ico,ip)), & + sum(dataGpr(f_h:f_h_end,ica,ip))+sum(dataGpr(f_h:f_h_end,icl,ip))+ & + sum(dataGpr(f_h:f_h_end,icn,ip))+sum(dataGpr(f_h:f_h_end,ics,ip))+sum(dataGpr(f_h:f_h_end,ico,ip)) + + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(ica),cname(icl),cname(icn),cname(ics),cname(ico),' *SUM* ' + do if = f_w, f_w_end + write(logunit,FA1) fname(if),dataGpr(if,ica,ip),dataGpr(if,icl,ip), & + dataGpr(if,icn,ip),dataGpr(if,ics,ip),dataGpr(if,ico,ip), & + dataGpr(if,ica,ip)+dataGpr(if,icl,ip)+ & + dataGpr(if,icn,ip)+dataGpr(if,ics,ip)+dataGpr(if,ico,ip) + enddo + write(logunit,FA1) ' *SUM*' ,sum(dataGpr(f_w:f_w_end,ica,ip)),sum(dataGpr(f_w:f_w_end,icl,ip)), & + sum(dataGpr(f_w:f_w_end,icn,ip)),sum(dataGpr(f_w:f_w_end,ics,ip)),sum(dataGpr(f_w:f_w_end,ico,ip)), & + sum(dataGpr(f_w:f_w_end,ica,ip))+sum(dataGpr(f_w:f_w_end,icl,ip))+ & + sum(dataGpr(f_w:f_w_end,icn,ip))+sum(dataGpr(f_w:f_w_end,ics,ip))+sum(dataGpr(f_w:f_w_end,ico,ip)) + + if ( flds_wiso )then + do is = 1, nisotopes + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & + trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(ica),cname(icl),cname(icn),cname(ics),cname(ico),' *SUM* ' + do if = iso0(is), isof(is) + write(logunit,FA1) fname(if),dataGpr(if,ica,ip),dataGpr(if,icl,ip), & + dataGpr(if,icn,ip),dataGpr(if,ics,ip),dataGpr(if,ico,ip), & + dataGpr(if,ica,ip)+dataGpr(if,icl,ip)+ & + dataGpr(if,icn,ip)+dataGpr(if,ics,ip)+dataGpr(if,ico,ip) + enddo + write(logunit,FA1) ' *SUM*', sum(dataGpr(iso0(is):isof(is),ica,ip)),sum(dataGpr(iso0(is):isof(is),icl,ip)), & + sum(dataGpr(iso0(is):isof(is),icn,ip)),sum(dataGpr(iso0(is):isof(is),ics,ip)), & + sum(dataGpr(iso0(is):isof(is),ico,ip)), & + sum(dataGpr(iso0(is):isof(is),ica,ip))+sum(dataGpr(iso0(is):isof(is),icl,ip))+ & + sum(dataGpr(iso0(is):isof(is),icn,ip))+sum(dataGpr(iso0(is):isof(is),ics,ip))+ & + sum(dataGpr(iso0(is):isof(is),ico,ip)) + end do + end if + + enddo + endif ! plev + + ! --------------------------------------------------------- + ! ---- detail lnd/ocn/ice component budgets ---- + ! --------------------------------------------------------- + + if (plev >= 2) then + do ic = 1,4 + if (ic == 1) then + icar = c_lnd_ar + icxs = c_lnd_ls + icxr = c_lnd_lr + icas = c_lnd_as + str = "LND" + elseif (ic == 2) then + icar = c_ocn_ar + icxs = c_ocn_os + icxr = c_ocn_or + icas = c_ocn_as + str = "OCN" + elseif (ic == 3) then + icar = c_inh_ar + icxs = c_inh_is + icxr = c_inh_ir + icas = c_inh_as + str = "ICE_NH" + elseif (ic == 4) then + icar = c_ish_ar + icxs = c_ish_is + icxr = c_ish_ir + icas = c_ish_as + str = "ICE_SH" + else + call shr_sys_abort(subname//' ERROR in ic index code 412') + endif + + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(icar),cname(icxs),cname(icxr),cname(icas),' *SUM* ' + do if = f_h, f_h_end + write(logunit,FA1) fname(if),-dataGpr(if,icar,ip),dataGpr(if,icxs,ip), & + dataGpr(if,icxr,ip),-dataGpr(if,icas,ip), & + -dataGpr(if,icar,ip)+dataGpr(if,icxs,ip)+ & + dataGpr(if,icxr,ip)-dataGpr(if,icas,ip) + enddo + write(logunit,FA1) ' *SUM*',-sum(dataGpr(f_h:f_h_end,icar,ip)),sum(dataGpr(f_h:f_h_end,icxs,ip)), & + sum(dataGpr(f_h:f_h_end,icxr,ip)),-sum(dataGpr(f_h:f_h_end,icas,ip)), & + -sum(dataGpr(f_h:f_h_end,icar,ip))+sum(dataGpr(f_h:f_h_end,icxs,ip))+ & + sum(dataGpr(f_h:f_h_end,icxr,ip))-sum(dataGpr(f_h:f_h_end,icas,ip)) + + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) cname(icar),cname(icxs),cname(icxr),cname(icas),' *SUM* ' + do if = f_w, f_w_end + write(logunit,FA1) fname(if),-dataGpr(if,icar,ip),dataGpr(if,icxs,ip), & + dataGpr(if,icxr,ip),-dataGpr(if,icas,ip), & + -dataGpr(if,icar,ip)+dataGpr(if,icxs,ip)+ & + dataGpr(if,icxr,ip)-dataGpr(if,icas,ip) + enddo + write(logunit,FA1) ' *SUM*',-sum(dataGpr(f_w:f_w_end,icar,ip)),sum(dataGpr(f_w:f_w_end,icxs,ip)), & + sum(dataGpr(f_w:f_w_end,icxr,ip)),-sum(dataGpr(f_w:f_w_end,icas,ip)), & + -sum(dataGpr(f_w:f_w_end,icar,ip))+sum(dataGpr(f_w:f_w_end,icxs,ip))+ & + sum(dataGpr(f_w:f_w_end,icxr,ip))-sum(dataGpr(f_w:f_w_end,icas,ip)) + + if ( flds_wiso ) then + do is = 1, nisotopes + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',trim(pname(ip)), & + ': date = ',cdate,sec + write(logunit,FA0) cname(icar),cname(icxs),cname(icxr),cname(icas),' *SUM* ' + do if = iso0(is), isof(is) + write(logunit,FA1) fname(if),-dataGpr(if,icar,ip),dataGpr(if,icxs,ip), & + dataGpr(if,icxr,ip),-dataGpr(if,icas,ip), & + -dataGpr(if,icar,ip)+dataGpr(if,icxs,ip)+ & + dataGpr(if,icxr,ip)-dataGpr(if,icas,ip) + enddo + write(logunit,FA1) ' *SUM*',-sum(dataGpr(iso0(is):isof(is),icar,ip)),sum(dataGpr(iso0(is):isof(is),icxs,ip)), & + sum(dataGpr(iso0(is):isof(is),icxr,ip)),-sum(dataGpr(iso0(is):isof(is),icas,ip)), & + -sum(dataGpr(iso0(is):isof(is),icar,ip))+sum(dataGpr(iso0(is):isof(is),icxs,ip))+ & + sum(dataGpr(iso0(is):isof(is),icxr,ip))-sum(dataGpr(iso0(is):isof(is),icas,ip)) + write(logunit,*) ' ' + write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',trim(pname(ip)),& + ': date = ',cdate,sec + write(logunit,FA0) cname(icar),cname(icxs),cname(icxr),cname(icas),' *SUM* ' + do if = iso0(is), isof(is) + write(logunit,FA1) fname(if),-dataGpr(if,icar,ip),dataGpr(if,icxs,ip), & + dataGpr(if,icxr,ip),-dataGpr(if,icas,ip), & + -dataGpr(if,icar,ip)+dataGpr(if,icxs,ip)+ & + dataGpr(if,icxr,ip)-dataGpr(if,icas,ip) + enddo + write(logunit,FA1) ' *SUM*',-sum(dataGpr(iso0(is):isof(is),icar,ip)),sum(dataGpr(iso0(is):isof(is),icxs,ip)), & + sum(dataGpr(iso0(is):isof(is),icxr,ip)),-sum(dataGpr(iso0(is):isof(is),icas,ip)), & + -sum(dataGpr(iso0(is):isof(is),icar,ip))+sum(dataGpr(iso0(is):isof(is),icxs,ip))+ & + sum(dataGpr(iso0(is):isof(is),icxr,ip))-sum(dataGpr(iso0(is):isof(is),icas,ip)) + end do + end if + enddo + endif ! plev + + ! --------------------------------------------------------- + ! ---- net summary budgets ---- + ! --------------------------------------------------------- + + if (plev >= 1) then + + write(logunit,*) ' ' + write(logunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0) ' atm',' lnd',' ocn',' ice nh',' ice sh',' *SUM* ' + do if = f_a,f_a_end + write(logunit,FA1) fname(if),dataGpr(if,c_atm_ar,ip), & + dataGpr(if,c_lnd_lr,ip), & + dataGpr(if,c_ocn_or,ip), & + dataGpr(if,c_inh_ir,ip), & + dataGpr(if,c_ish_ir,ip), & + dataGpr(if,c_atm_ar,ip)+ & + dataGpr(if,c_lnd_lr,ip)+ & + dataGpr(if,c_ocn_or,ip)+ & + dataGpr(if,c_inh_ir,ip)+ & + dataGpr(if,c_ish_ir,ip) + enddo + + write(logunit,*) ' ' + write(logunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + do if = f_h, f_h_end + write(logunit,FA1r) fname(if),dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip), & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip), & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip), & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip), & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip), & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip), & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip), & + dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip)+ & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip)+ & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip)+ & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip)+ & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip)+ & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip)+ & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip) + enddo + write(logunit,FA1r)' *SUM*',sum(dataGpr(f_h:f_h_end,c_atm_ar,ip))+sum(dataGpr(f_h:f_h_end,c_atm_as,ip)), & + sum(dataGpr(f_h:f_h_end,c_lnd_lr,ip))+sum(dataGpr(f_h:f_h_end,c_lnd_ls,ip)), & + sum(dataGpr(f_h:f_h_end,c_rof_rr,ip))+sum(dataGpr(f_h:f_h_end,c_rof_rs,ip)), & + sum(dataGpr(f_h:f_h_end,c_ocn_or,ip))+sum(dataGpr(f_h:f_h_end,c_ocn_os,ip)), & + sum(dataGpr(f_h:f_h_end,c_inh_ir,ip))+sum(dataGpr(f_h:f_h_end,c_inh_is,ip)), & + sum(dataGpr(f_h:f_h_end,c_ish_ir,ip))+sum(dataGpr(f_h:f_h_end,c_ish_is,ip)), & + sum(dataGpr(f_h:f_h_end,c_glc_gr,ip))+sum(dataGpr(f_h:f_h_end,c_glc_gs,ip)), & + sum(dataGpr(f_h:f_h_end,c_atm_ar,ip))+sum(dataGpr(f_h:f_h_end,c_atm_as,ip))+ & + sum(dataGpr(f_h:f_h_end,c_lnd_lr,ip))+sum(dataGpr(f_h:f_h_end,c_lnd_ls,ip))+ & + sum(dataGpr(f_h:f_h_end,c_rof_rr,ip))+sum(dataGpr(f_h:f_h_end,c_rof_rs,ip))+ & + sum(dataGpr(f_h:f_h_end,c_ocn_or,ip))+sum(dataGpr(f_h:f_h_end,c_ocn_os,ip))+ & + sum(dataGpr(f_h:f_h_end,c_inh_ir,ip))+sum(dataGpr(f_h:f_h_end,c_inh_is,ip))+ & + sum(dataGpr(f_h:f_h_end,c_ish_ir,ip))+sum(dataGpr(f_h:f_h_end,c_ish_is,ip))+ & + sum(dataGpr(f_h:f_h_end,c_glc_gr,ip))+sum(dataGpr(f_h:f_h_end,c_glc_gs,ip)) + + write(logunit,*) ' ' + write(logunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + do if = f_w, f_w_end + write(logunit,FA1r) fname(if),dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip), & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip), & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip), & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip), & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip), & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip), & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip), & + dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip)+ & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip)+ & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip)+ & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip)+ & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip)+ & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip)+ & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip) + enddo + write(logunit,FA1r)' *SUM*',sum(dataGpr(f_w:f_w_end,c_atm_ar,ip))+sum(dataGpr(f_w:f_w_end,c_atm_as,ip)), & + sum(dataGpr(f_w:f_w_end,c_lnd_lr,ip))+sum(dataGpr(f_w:f_w_end,c_lnd_ls,ip)), & + sum(dataGpr(f_w:f_w_end,c_rof_rr,ip))+sum(dataGpr(f_w:f_w_end,c_rof_rs,ip)), & + sum(dataGpr(f_w:f_w_end,c_ocn_or,ip))+sum(dataGpr(f_w:f_w_end,c_ocn_os,ip)), & + sum(dataGpr(f_w:f_w_end,c_inh_ir,ip))+sum(dataGpr(f_w:f_w_end,c_inh_is,ip)), & + sum(dataGpr(f_w:f_w_end,c_ish_ir,ip))+sum(dataGpr(f_w:f_w_end,c_ish_is,ip)), & + sum(dataGpr(f_w:f_w_end,c_glc_gr,ip))+sum(dataGpr(f_w:f_w_end,c_glc_gs,ip)), & + sum(dataGpr(f_w:f_w_end,c_atm_ar,ip))+sum(dataGpr(f_w:f_w_end,c_atm_as,ip))+ & + sum(dataGpr(f_w:f_w_end,c_lnd_lr,ip))+sum(dataGpr(f_w:f_w_end,c_lnd_ls,ip))+ & + sum(dataGpr(f_w:f_w_end,c_rof_rr,ip))+sum(dataGpr(f_w:f_w_end,c_rof_rs,ip))+ & + sum(dataGpr(f_w:f_w_end,c_ocn_or,ip))+sum(dataGpr(f_w:f_w_end,c_ocn_os,ip))+ & + sum(dataGpr(f_w:f_w_end,c_inh_ir,ip))+sum(dataGpr(f_w:f_w_end,c_inh_is,ip))+ & + sum(dataGpr(f_w:f_w_end,c_ish_ir,ip))+sum(dataGpr(f_w:f_w_end,c_ish_is,ip))+ & + sum(dataGpr(f_w:f_w_end,c_glc_gr,ip))+sum(dataGpr(f_w:f_w_end,c_glc_gs,ip)) + + if ( flds_wiso ) then + + do is = 1, nisotopes + write(logunit,*) ' ' + write(logunit,FAH) subname,'NET '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & + trim(pname(ip)),': date = ',cdate,sec + write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + do if = iso0(is), isof(is) + write(logunit,FA1r) fname(if),dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip), & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip), & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip), & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip), & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip), & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip), & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip), & + dataGpr(if,c_atm_ar,ip)+dataGpr(if,c_atm_as,ip)+ & + dataGpr(if,c_lnd_lr,ip)+dataGpr(if,c_lnd_ls,ip)+ & + dataGpr(if,c_rof_rr,ip)+dataGpr(if,c_rof_rs,ip)+ & + dataGpr(if,c_ocn_or,ip)+dataGpr(if,c_ocn_os,ip)+ & + dataGpr(if,c_inh_ir,ip)+dataGpr(if,c_inh_is,ip)+ & + dataGpr(if,c_ish_ir,ip)+dataGpr(if,c_ish_is,ip)+ & + dataGpr(if,c_glc_gr,ip)+dataGpr(if,c_glc_gs,ip) + enddo + write(logunit,FA1r)' *SUM*',sum(dataGpr(iso0(is):isof(is),c_atm_ar,ip))+sum(dataGpr(iso0(is):isof(is),c_atm_as,ip)),& + sum(dataGpr(iso0(is):isof(is),c_lnd_lr,ip))+sum(dataGpr(iso0(is):isof(is),c_lnd_ls,ip)),& + sum(dataGpr(iso0(is):isof(is),c_rof_rr,ip))+sum(dataGpr(iso0(is):isof(is),c_rof_rs,ip)),& + sum(dataGpr(iso0(is):isof(is),c_ocn_or,ip))+sum(dataGpr(iso0(is):isof(is),c_ocn_os,ip)),& + sum(dataGpr(iso0(is):isof(is),c_inh_ir,ip))+sum(dataGpr(iso0(is):isof(is),c_inh_is,ip)),& + sum(dataGpr(iso0(is):isof(is),c_ish_ir,ip))+sum(dataGpr(iso0(is):isof(is),c_ish_is,ip)),& + sum(dataGpr(iso0(is):isof(is),c_glc_gr,ip))+sum(dataGpr(iso0(is):isof(is),c_glc_gs,ip)),& + sum(dataGpr(iso0(is):isof(is),c_atm_ar,ip))+sum(dataGpr(iso0(is):isof(is),c_atm_as,ip))+& + sum(dataGpr(iso0(is):isof(is),c_lnd_lr,ip))+sum(dataGpr(iso0(is):isof(is),c_lnd_ls,ip))+& + sum(dataGpr(iso0(is):isof(is),c_rof_rr,ip))+sum(dataGpr(iso0(is):isof(is),c_rof_rs,ip))+& + sum(dataGpr(iso0(is):isof(is),c_ocn_or,ip))+sum(dataGpr(iso0(is):isof(is),c_ocn_os,ip))+& + sum(dataGpr(iso0(is):isof(is),c_inh_ir,ip))+sum(dataGpr(iso0(is):isof(is),c_inh_is,ip))+& + sum(dataGpr(iso0(is):isof(is),c_ish_ir,ip))+sum(dataGpr(iso0(is):isof(is),c_ish_is,ip))+& + sum(dataGpr(iso0(is):isof(is),c_glc_gr,ip))+sum(dataGpr(iso0(is):isof(is),c_glc_gs,ip)) + end do + end if + + endif + + write(logunit,*) ' ' +! ---- doprint ---- doprint ---- doprint ---- + endif ! plev > 0 + enddo ! ip = 1,p_size + +end subroutine seq_diag_print_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_avect_mct - print global budget diagnostics +! +! !DESCRIPTION: +! Print global diagnostics for AV/ID. +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_diag_avect_mct(infodata, id, av, dom, gsmap, comment) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type) , intent(in) :: infodata + integer(in) , intent(in) :: ID + type(mct_aVect) , intent(in) :: av + type(mct_gGrid) , pointer :: dom + type(mct_gsMap) , pointer :: gsmap + character(len=*) , intent(in), optional :: comment + +!EOP + + !--- local --- + logical :: bfbflag + integer(in) :: n,k ! counters + integer(in) :: npts,nptsg ! number of local/global pts in AV + integer(in) :: kflds ! number of fields in AV + real(r8), pointer :: sumbuf (:) ! sum buffer + real(r8), pointer :: minbuf (:) ! min buffer + real(r8), pointer :: maxbuf (:) ! max buffer + real(r8), pointer :: sumbufg(:) ! sum buffer reduced + real(r8), pointer :: minbufg(:) ! min buffer reduced + real(r8), pointer :: maxbufg(:) ! max buffer reduced + integer(i8), pointer :: isumbuf (:) ! integer local sum + integer(i8), pointer :: isumbufg(:) ! integer global sum + integer(i8) :: ihuge ! huge + integer(in) :: mpicom ! mpi comm + integer(in) :: iam ! pe number + integer(in) :: km,ka ! field indices + integer(in) :: ns ! size of local AV + integer(in) :: rcode ! error code + real(r8), pointer :: weight(:) ! weight + type(mct_string) :: mstring ! mct char type + character(CL) :: lcomment ! should be long enough + character(CL) :: itemc ! string converted to char + + type(mct_avect) :: AV1 ! local avect with one field + type(mct_avect) :: AVr1 ! avect on root with one field + type(mct_avect) :: AVr2 ! avect on root with one field + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_avect_mct) ' + character(*),parameter :: F00 = "('(seq_diag_avect_mct) ',4a)" + +!------------------------------------------------------------------------------- +! print instantaneous budget data +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(ID,& + mpicom=mpicom, iam=iam) + + call seq_infodata_GetData(infodata,& + bfbflag=bfbflag) + + lcomment = '' + if (present(comment)) then + lcomment=trim(comment) + endif + + ns = mct_aVect_lsize(AV) + npts = mct_aVect_lsize(dom%data) + if (ns /= npts) call shr_sys_abort(trim(subname)//' ERROR: size of AV,dom') + km = mct_aVect_indexRA(dom%data,'mask') + ka = mct_aVect_indexRA(dom%data,afldname) + kflds = mct_aVect_nRattr(AV) + allocate(sumbuf(kflds),sumbufg(kflds)) + + sumbuf = 0.0_r8 + + if (bfbflag) then + + npts = mct_aVect_lsize(AV) + allocate(weight(npts)) + weight(:) = 1.0_r8 + do n = 1,npts + if (dom%data%rAttr(km,n) <= 1.0e-06_R8) then + weight(n) = 0.0_r8 + else + weight(n) = dom%data%rAttr(ka,n)*shr_const_rearth*shr_const_rearth + endif + enddo + + allocate(maxbuf(kflds),maxbufg(kflds)) + maxbuf = 0.0_r8 + + do n = 1,npts + do k = 1,kflds + if (.not. shr_const_isspval(AV%rAttr(k,n))) then + maxbuf(k) = max(maxbuf(k),abs(AV%rAttr(k,n)*weight(n))) + endif + enddo + enddo + + call shr_mpi_max(maxbuf,maxbufg,mpicom,subname,all=.true.) + call shr_mpi_sum(npts,nptsg,mpicom,subname,all=.true.) + + do k = 1,kflds + if (maxbufg(k) < 1000.0*TINY(maxbufg(k)) .or. & + maxbufg(k) > HUGE(maxbufg(k))/(2.0_r8*nptsg)) then + maxbufg(k) = 0.0_r8 + else + maxbufg(k) = (1.1_r8) * maxbufg(k) * nptsg + endif + enddo + + allocate(isumbuf(kflds),isumbufg(kflds)) + isumbuf = 0 + ihuge = HUGE(isumbuf) + + do n = 1,npts + do k = 1,kflds + if (.not. shr_const_isspval(AV%rAttr(k,n))) then + if (abs(maxbufg(k)) > 1000.0_r8 * TINY(maxbufg)) then + isumbuf(k) = isumbuf(k) + int((AV%rAttr(k,n)*weight(n)/maxbufg(k))*ihuge,i8) + endif + endif + enddo + enddo + + call shr_mpi_sum(isumbuf,isumbufg,mpicom,subname) + + do k = 1,kflds + sumbufg(k) = isumbufg(k)*maxbufg(k)/ihuge + enddo + + deallocate(weight) + deallocate(maxbuf,maxbufg) + deallocate(isumbuf,isumbufg) + + else + + npts = mct_aVect_lsize(AV) + allocate(weight(npts)) + weight(:) = 1.0_r8 + do n = 1,npts + if (dom%data%rAttr(km,n) <= 1.0e-06_R8) then + weight(n) = 0.0_r8 + else + weight(n) = dom%data%rAttr(ka,n)*shr_const_rearth*shr_const_rearth + endif + enddo + + do n = 1,npts + do k = 1,kflds + if (.not. shr_const_isspval(AV%rAttr(k,n))) then + sumbuf(k) = sumbuf(k) + AV%rAttr(k,n)*weight(n) + endif + enddo + enddo + + !--- global reduction --- + call shr_mpi_sum(sumbuf,sumbufg,mpicom,subname) + + deallocate(weight) + + endif + + if (iam == 0) then + ! write(logunit,*) 'sdAV: *** writing ',trim(lcomment),': k fld min/max/sum ***' + do k = 1,kflds + call mct_aVect_getRList(mstring,k,AV) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + if (len_trim(lcomment) > 0) then + write(logunit,100) 'xxx','sorr',k,sumbufg(k),trim(lcomment),trim(itemc) + else + write(logunit,101) 'xxx','sorr',k,sumbufg(k),trim(itemc) + endif + enddo + call shr_sys_flush(logunit) + endif + + deallocate(sumbuf,sumbufg) + +100 format('comm_diag ',a3,1x,a4,1x,i3,es26.19,1x,a,1x,a) +101 format('comm_diag ',a3,1x,a4,1x,i3,es26.19,1x,a) + +end subroutine seq_diag_avect_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_avloc_mct - print local budget diagnostics +! +! !DESCRIPTION: +! Print local diagnostics for AV/ID. +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_diag_avloc_mct(av, comment) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) , intent(in) :: av + character(len=*), intent(in), optional :: comment + +!EOP + + !--- local --- + integer(in) :: n,k ! counters + integer(in) :: npts ! number of local/global pts in AV + integer(in) :: kflds ! number of fields in AV + real(r8), pointer :: sumbuf (:) ! sum buffer + type(mct_string) :: mstring ! mct char type + character(CL) :: lcomment ! should be long enough + character(CL) :: itemc ! string converted to char + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_avloc_mct) ' + character(*),parameter :: F00 = "('(seq_diag_avloc_mct) ',4a)" + +!------------------------------------------------------------------------------- +! print instantaneous budget data +!------------------------------------------------------------------------------- + + lcomment = '' + if (present(comment)) then + lcomment=trim(comment) + endif + + npts = mct_aVect_lsize(AV) + kflds = mct_aVect_nRattr(AV) + allocate(sumbuf(kflds)) + + sumbuf = 0.0_r8 + do n = 1,npts + do k = 1,kflds +! if (.not. shr_const_isspval(AV%rAttr(k,n))) then + sumbuf(k) = sumbuf(k) + AV%rAttr(k,n) +! endif + enddo + enddo + + do k = 1,kflds + call mct_aVect_getRList(mstring,k,AV) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + if (len_trim(lcomment) > 0) then + write(logunit,100) 'xxx','sorr',k,sumbuf(k),trim(lcomment),trim(itemc) + else + write(logunit,101) 'xxx','sorr',k,sumbuf(k),trim(itemc) + endif + enddo + call shr_sys_flush(logunit) + + deallocate(sumbuf) + +100 format('avloc_diag ',a3,1x,a4,1x,i3,es26.19,1x,a,1x,a) +101 format('avloc_diag ',a3,1x,a4,1x,i3,es26.19,1x,a) + +end subroutine seq_diag_avloc_mct + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_diag_avdiff_mct - print global budget diagnostics +! +! !DESCRIPTION: +! Print global diagnostics for AV/ID. +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_diag_avdiff_mct(AV1,AV2,ID,comment) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) , intent(in) :: AV1 + type(mct_aVect) , intent(in) :: AV2 + integer , intent(in) :: ID + character(len=*), intent(in), optional :: comment + +!EOP + + !--- local --- + integer(in) :: n,k,n1,k1,n2,k2 ! counters + integer(in) :: iam ! pe number + integer(in) :: cnt ! counter + real(r8) :: adiff,rdiff ! diff values + type(mct_string) :: mstring ! mct char type + character(len=64):: lcomment ! should be long enough + + !----- formats ----- + character(*),parameter :: subName = '(seq_diag_avdiff_mct) ' + character(*),parameter :: F00 = "('(seq_diag_avdiff_mct) ',4a)" + +!------------------------------------------------------------------------------- +! print instantaneous budget data +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(ID,iam=iam) + + lcomment = '' + if (present(comment)) then + lcomment=trim(comment) + endif + + n1 = mct_aVect_lsize(AV1) + k1 = mct_aVect_nRattr(AV1) + n2 = mct_aVect_lsize(AV2) + k2 = mct_aVect_nRattr(AV2) + + if (n1 /= n2 .or. k1 /= k2) then + write(s_logunit,*) subname,trim(lcomment),' AV sizes different ',n1,n2,k1,k2 + return + endif + + do k = 1,k1 + cnt = 0 + adiff = 0. + rdiff = 0. + do n = 1,n1 + if (AV1%rAttr(k,n) /= AV2%rAttr(k,n)) then + cnt = cnt + 1 + adiff = max(adiff, abs(AV1%rAttr(k,n)-AV2%rAttr(k,n))) + rdiff = max(rdiff, abs(AV1%rAttr(k,n)-AV2%rAttr(k,n))/(abs(AV1%rAttr(k,n))+abs(AV2%rAttr(k,n)))) + endif + enddo + if (cnt > 0) then + call mct_aVect_getRList(mstring,k,AV1) + write(s_logunit,*) subname,trim(lcomment),' AVs fld k diff ', & + iam,mct_string_toChar(mstring),cnt,adiff,rdiff, & + minval(AV1%rAttr(k,:)),minval(AV1%rAttr(k,:)), & + maxval(AV1%rAttr(k,:)),maxval(AV2%rAttr(k,:)) + call mct_string_clean(mstring) + endif + enddo + +end subroutine seq_diag_avdiff_mct + +!=============================================================================== +end module seq_diag_mct diff --git a/driver-mct/main/seq_domain_mct.F90 b/driver-mct/main/seq_domain_mct.F90 new file mode 100644 index 000000000000..bc85b754ccb2 --- /dev/null +++ b/driver-mct/main/seq_domain_mct.F90 @@ -0,0 +1,793 @@ +module seq_domain_mct + + use shr_kind_mod, only: R8=>shr_kind_r8, IN=>shr_kind_in + use shr_kind_mod, only: CL=>shr_kind_cl + use shr_sys_mod, only: shr_sys_flush, shr_sys_abort + use shr_mpi_mod, only: shr_mpi_min, shr_mpi_max + + use mct_mod + use seq_comm_mct + use seq_infodata_mod + use seq_map_mod , only: seq_map_map + use seq_map_type_mod, only: seq_map + + use component_type_mod + + implicit none + private ! except +#include + save + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: seq_domain_check + public :: seq_domain_compare + public :: seq_domain_areafactinit + +!-------------------------------------------------------------------------- +! Public variables +!-------------------------------------------------------------------------- + + real(R8), parameter :: eps_tiny = 1.0e-16_R8 ! roundoff eps + real(R8), parameter :: eps_big = 1.0e+02_R8 ! big eps + real(R8), parameter :: eps_frac_samegrid = 1.0e-9_R8 ! epsilon for fractions for samegrid + +!-------------------------------------------------------------------------- +! Private interfaces +!-------------------------------------------------------------------------- + + private :: seq_domain_check_grid + +!================================================================================ +contains +!================================================================================ + +!================================================================================ + + subroutine seq_domain_check( infodata, & + atm, ice, lnd, ocn, rof, glc, & + samegrid_al, samegrid_ao, samegrid_ro, samegrid_lg) + + !----------------------------------------------------------- + ! Uses + ! + use prep_atm_mod, only: prep_atm_get_mapper_Fi2a + use prep_atm_mod, only: prep_atm_get_mapper_Fl2a + use prep_atm_mod, only: prep_atm_get_mapper_Fo2a + use prep_lnd_mod, only: prep_lnd_get_mapper_Fa2l + use prep_ocn_mod, only: prep_ocn_get_mapper_SFi2o + use prep_glc_mod, only: prep_glc_get_mapper_Fl2g + ! + ! Arguments + ! + type (seq_infodata_type) , intent(inout) :: infodata + type(component_type) , intent(in) :: atm + type(component_type) , intent(in) :: ice + type(component_type) , intent(in) :: lnd + type(component_type) , intent(in) :: ocn + type(component_type) , intent(in) :: rof + type(component_type) , intent(in) :: glc + logical , intent(in) :: samegrid_al ! atm lnd grid same + logical , intent(in) :: samegrid_ao ! atm ocn grid same + logical , intent(in) :: samegrid_ro ! rof ocn grid same + logical , intent(in) :: samegrid_lg ! lnd glc grid same + ! + ! Local variables + ! + type(seq_map) , pointer :: mapper_i2a ! inout needed for lower methods + type(seq_map) , pointer :: mapper_i2o ! inout needed for lower methods + type(seq_map) , pointer :: mapper_o2a ! + type(seq_map) , pointer :: mapper_l2g ! + type(seq_map) , pointer :: mapper_a2l ! + type(seq_map) , pointer :: mapper_l2a ! + ! + type(mct_gGrid) , pointer :: atmdom_a ! atm domain + type(mct_gGrid) , pointer :: icedom_i ! ice domain + type(mct_gGrid) , pointer :: lnddom_l ! lnd domain + type(mct_gGrid) , pointer :: ocndom_o ! ocn domain + type(mct_gGrid) , pointer :: glcdom_g ! glc domain + ! + type(mct_gsMap) , pointer :: gsMap_a ! atm global seg map + type(mct_gsMap) , pointer :: gsMap_i ! ice global seg map + type(mct_gsMap) , pointer :: gsMap_l ! lnd global seg map + type(mct_gsMap) , pointer :: gsMap_o ! ocn global seg map + type(mct_gsMap) , pointer :: gsMap_r ! ocn global seg map + type(mct_gsMap) , pointer :: gsMap_g ! glc global seg map + ! + type(mct_gGrid) :: lnddom_a ! lnd domain info on atm decomp + type(mct_gGrid) :: lnddom_g ! lnd domain info on glc decomp + type(mct_gGrid) :: icedom_a ! ice domain info on atm decomp (all grids same) + type(mct_gGrid) :: ocndom_a ! ocn domain info on atm decomp (all grids same) + type(mct_gGrid) :: icedom_o ! ocn domain info on ocn decomp (atm/ocn grid different) + ! + real(R8), pointer :: fracl(:) ! land fraction on atm decomp + real(R8), pointer :: fraco(:) ! ocn fraction on atm decomp + real(R8), pointer :: fraci(:) ! ice fraction on atm decomp + real(R8), pointer :: maskl(:) ! land mask on atm decomp (all grids same) + real(R8), pointer :: maski(:) ! ice mask on atm decomp (all grids same) + real(R8), pointer :: masko(:) ! ocn mask on atm decomp (all grids same) + ! + integer(IN) :: n, kl, ko, ki ! indicies + integer(IN) :: k1,k2,k3 ! indicies + ! + integer(IN) :: mpicom_cplid + ! + logical :: atm_present ! atm present flag + logical :: lnd_present ! lnd present flag + logical :: ocn_present ! ocn present flag + logical :: ice_present ! ice present flag + logical :: glc_present ! glc present flag + logical :: rof_present ! rof present flag + logical :: ocnrof_prognostic ! ocn rof prognostic flag + integer(IN) :: rcode ! error status + integer(IN) :: atmsize ! local size of atm grid + integer(IN) :: lndsize ! local size of land grid + integer(IN) :: ocnsize ! local size of ocn grid + integer(IN) :: icesize ! local size of ice grid + integer(IN) :: glcsize ! local size of glc grid + integer(IN) :: gatmsize ! global size of atm grid + integer(IN) :: glndsize ! global size of land grid + integer(IN) :: gocnsize ! global size of ocn grid + integer(IN) :: grofsize ! global size of ocn grid + integer(IN) :: gicesize ! global size of ice grid + integer(IN) :: gglcsize ! global size of glc grid + integer(IN) :: npts ! local size temporary + integer(IN) :: ier ! error code + real(R8) :: diff,dmaxo,dmaxi ! difference tracker + logical :: iamroot ! local masterproc + real(R8) :: eps_frac ! epsilon for fractions + real(R8) :: eps_axmask ! epsilon for masks, atm/lnd + real(R8) :: eps_axgrid ! epsilon for grid coords, atm/lnd + real(R8) :: eps_axarea ! epsilon for areas, atm/lnd + real(R8) :: eps_oimask ! epsilon for masks, ocn/ice + real(R8) :: eps_oigrid ! epsilon for grid coords, ocn/ice + real(R8) :: eps_oiarea ! epsilon for areas, ocn/ice + real(R8) :: my_eps_frac ! local eps_frac value + real(R8) :: rmin1,rmax1,rmin,rmax ! local min max computation + ! + real(R8),allocatable :: mask (:) ! temporary real vector, domain mask + ! + character(*),parameter :: F00 = "('(seq_domain_check) ',4a)" + character(*),parameter :: F01 = "('(seq_domain_check) ',a,i6,a)" + character(*),parameter :: F02 = "('(seq_domain_check) ',a,g23.15)" + character(*),parameter :: F0R = "('(seq_domain_check) ',2A,2g23.15,A )" + character(*),parameter :: subName = '(seq_domain_check) ' + !----------------------------------------------------------- + + mapper_i2a => prep_atm_get_mapper_Fi2a() + mapper_i2o => prep_ocn_get_mapper_SFi2o() + mapper_o2a => prep_atm_get_mapper_Fo2a() + mapper_l2g => prep_glc_get_mapper_Fl2g() + mapper_a2l => prep_lnd_get_mapper_Fa2l() + mapper_l2a => prep_atm_get_mapper_Fl2a() + + call seq_comm_setptrs(CPLID,iamroot=iamroot, mpicom=mpicom_cplid) + + call seq_infodata_GetData( infodata, & + lnd_present=lnd_present, & + ocn_present=ocn_present, & + ice_present=ice_present, & + glc_present=glc_present, & + atm_present=atm_present, & + rof_present=rof_present, & + ocnrof_prognostic=ocnrof_prognostic, & + eps_frac=eps_frac, & + eps_amask=eps_axmask, & + eps_agrid=eps_axgrid, & + eps_aarea=eps_axarea, & + eps_omask=eps_oimask, & + eps_ogrid=eps_oigrid, & + eps_oarea=eps_oiarea ) + + ! Get info + + if (atm_present) then + gsmap_a => component_get_gsmap_cx(atm) ! gsmap_ax + atmdom_a => component_get_dom_cx(atm) ! dom_ax + atmsize = mct_avect_lsize(atmdom_a%data) + gatmsize = mct_gsMap_gsize(gsMap_a) + end if + + if (atm_present .and. lnd_present) then + gsmap_l => component_get_gsmap_cx(lnd) ! gsmap_lx + lnddom_l => component_get_dom_cx(lnd) ! dom_lx + lndsize = mct_avect_lsize(lnddom_l%data) + glndsize = mct_gsMap_gsize(gsMap_l) + + if (samegrid_al .and. gatmsize /= glndsize) then + write(logunit,*) subname,' error: global atmsize = ',& + gatmsize,' global lndsize= ',glndsize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' atm and lnd grid must have the same global size') + end if + if (iamroot) write(logunit,F00) ' --- checking land maskfrac ---' + call seq_domain_check_fracmask(lnddom_l%data) + call mct_gGrid_init(oGGrid=lnddom_a, iGGrid=lnddom_l, lsize=atmsize) + call mct_aVect_zero(lnddom_a%data) + call seq_map_map(mapper_l2a, lnddom_l%data, lnddom_a%data, norm=.false.) + allocate(maskl(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate maskl') + allocate(fracl(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate fracl') + call mct_aVect_exportRAttr(lnddom_a%data, 'mask', maskl, atmsize) + call mct_aVect_exportRAttr(lnddom_a%data, 'frac', fracl, atmsize) + endif + + if (atm_present .and. ocn_present) then + gsmap_o => component_get_gsmap_cx(ocn) ! gsmap_ox + ocndom_o => component_get_dom_cx(ocn) ! dom_ox + ocnsize = mct_avect_lsize(ocndom_o%data) + gocnsize = mct_gsMap_gsize(gsMap_o) + + if (samegrid_ao .and. gatmsize /= gocnsize) then + write(logunit,*) subname,' error: global atmsize = ',gatmsize,' global ocnsize= ',gocnsize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' atm and ocn grid must have the same global size') + end if + if (iamroot) write(logunit,F00) ' --- checking ocean maskfrac ---' + call seq_domain_check_fracmask(ocndom_o%data) + call mct_gGrid_init(oGGrid=ocndom_a, iGGrid=ocndom_o, lsize=atmsize) + call mct_aVect_zero(ocndom_a%data) + call seq_map_map(mapper_o2a, ocndom_o%data, ocndom_a%data, norm=.false.) + allocate(masko(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate masko') + allocate(fraco(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate fraco') + call mct_aVect_exportRAttr(ocndom_a%data, 'mask', masko, atmsize) + if (samegrid_ao) then + call mct_aVect_exportRattr(ocndom_a%data, 'frac', fraco, atmsize) + else + call mct_aVect_exportRattr(ocndom_a%data, 'mask', fraco, atmsize) + endif + endif + + if (atm_present .and. ice_present) then + gsmap_i => component_get_gsmap_cx(ice) ! gsmap_ix + icedom_i => component_get_dom_cx(ice) ! dom_ix + icesize = mct_avect_lsize(icedom_i%data) + gicesize = mct_gsMap_gsize(gsMap_i) + + if (samegrid_ao .and. gatmsize /= gicesize) then + write(logunit,*) subname,' error: global atmsize = ',& + gatmsize,' global icesize= ',gicesize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' atm and ice grid must have the same global size') + end if + if (iamroot) write(logunit,F00) ' --- checking ice maskfrac ---' + call seq_domain_check_fracmask(icedom_i%data) + call mct_gGrid_init(oGGrid=icedom_a, iGGrid=icedom_i, lsize=atmsize) + call mct_aVect_zero(icedom_a%data) + call seq_map_map(mapper_i2a, icedom_i%data, icedom_a%data, norm=.false.) + allocate(maski(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate maski') + allocate(fraci(atmsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate fraci') + call mct_aVect_exportRAttr(icedom_a%data, 'mask', maski, atmsize) + if (samegrid_ao) then + call mct_aVect_exportRattr(icedom_a%data, 'frac', fraci, atmsize) + else + call mct_aVect_exportRattr(icedom_a%data, 'mask', fraci, atmsize) + endif + endif + + if (lnd_present .and. glc_present) then + gsmap_l => component_get_gsmap_cx(lnd) ! gsmap_lx + lnddom_l => component_get_dom_cx(lnd) ! dom_lx + lndsize = mct_avect_lsize(lnddom_l%data) + glndsize = mct_gsMap_gsize(gsMap_l) + + gsmap_g => component_get_gsmap_cx(glc) ! gsmap_gx + glcdom_g => component_get_dom_cx(glc) ! dom_gx + glcsize = mct_avect_lsize(glcdom_g%data) + gglcsize = mct_gsMap_gsize(gsMap_g) + + if (samegrid_lg .and. gglcsize /= glndsize) then + write(logunit,*) subname,' error: global glcsize = ',gglcsize,' global lndsize= ',glndsize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' glc and lnd grid must have the same global size') + end if + + if (iamroot) write(logunit,F00) ' --- checking glc maskfrac ---' + call seq_domain_check_fracmask(glcdom_g%data) + if (iamroot) write(logunit,F00) ' --- checking lnd maskfrac ---' + call seq_domain_check_fracmask(lnddom_l%data) + + if (samegrid_lg) then + call mct_gGrid_init(oGGrid=lnddom_g, iGGrid=lnddom_l, lsize=glcsize) + call mct_aVect_zero(lnddom_g%data) + call seq_map_map(mapper_l2g, lnddom_l%data, lnddom_g%data, norm=.false.) + if (iamroot) write(logunit,F00) ' --- checking glc/lnd domains ---' + npts = glcsize + allocate(mask(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate mask') + call mct_aVect_getRAttr(lnddom_g%data,"mask",mask,rcode) + where (mask < eps_axmask) mask = 0.0_R8 + call seq_domain_check_grid(glcdom_g%data, lnddom_g%data, 'mask', eps=eps_axmask, mpicom=mpicom_cplid, mask=mask) + call seq_domain_check_grid(glcdom_g%data, lnddom_g%data, 'lat' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=mask) + call seq_domain_check_grid(glcdom_g%data, lnddom_g%data, 'lon' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=mask) + call seq_domain_check_grid(glcdom_g%data, lnddom_g%data, 'area', eps=eps_axarea, mpicom=mpicom_cplid, mask=mask) + deallocate(mask,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate mask') + end if + + endif + + if (ice_present .and. ocn_present) then + gsmap_i => component_get_gsmap_cx(ice) ! gsmap_ix + icedom_i => component_get_dom_cx(ice) ! dom_ix + icesize = mct_avect_lsize(icedom_i%data) + gicesize = mct_gsMap_gsize(gsMap_i) + + gsmap_o => component_get_gsmap_cx(ocn) ! gsmap_ox + ocndom_o => component_get_dom_cx(ocn) ! dom_ox + ocnsize = mct_avect_lsize(ocndom_o%data) + gocnsize = mct_gsMap_gsize(gsMap_o) + + if (gocnsize /= gicesize) then + write(logunit,*) subname,' error: global ocnsize = ',gocnsize,' global icesize= ',gicesize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' ocean and ice grid must have the same global size') + endif + call mct_gGrid_init(oGGrid=icedom_o, iGGrid=icedom_i, lsize=ocnsize) + call mct_aVect_zero(icedom_o%data) + call seq_map_map(mapper_i2o, icedom_i%data, icedom_o%data, norm=.false.) + end if + + if (rof_present .and. ocnrof_prognostic .and. samegrid_ro) then + gsmap_r => component_get_gsmap_cx(glc) ! gsmap_gx + grofsize = mct_gsMap_gsize(gsMap_r) + + if (gocnsize /= grofsize) then + write(logunit,*) subname,' error: global ocnsize = ',gocnsize,' global rofsize= ',grofsize + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' ocean and rof grid must have the same global size') + endif + end if + + !------------------------------------------------------------------------------ + ! Check ice/ocean grid consistency + !------------------------------------------------------------------------------ + + if (ocn_present .and. ice_present) then +! if (samegrid_oi) then ! doesn't yet exist + + npts = ocnsize + allocate(mask(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate mask') + + if (iamroot) write(logunit,F00) ' --- checking ocn/ice domains ---' + call seq_domain_check_grid(ocndom_o%data, icedom_o%data,'mask', eps=eps_oigrid, mpicom=mpicom_cplid) + call mct_aVect_getRAttr(ocndom_o%data,"mask",mask,rcode) + where (mask < eps_oimask) mask = 0.0_R8 + + call seq_domain_check_grid(ocndom_o%data, icedom_o%data,'lat' , eps=eps_oigrid, mpicom=mpicom_cplid, mask=mask) + call seq_domain_check_grid(ocndom_o%data, icedom_o%data,'lon' , eps=eps_oigrid, mpicom=mpicom_cplid, mask=mask) + call seq_domain_check_grid(ocndom_o%data, icedom_o%data,'area', eps=eps_oiarea, mpicom=mpicom_cplid, mask=mask) + + deallocate(mask,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate mask') + +! endif + endif + + !------------------------------------------------------------------------------ + ! Check atm/lnd grid consistency + !------------------------------------------------------------------------------ + + if (atm_present .and. lnd_present .and. samegrid_al) then + if (iamroot) write(logunit,F00) ' --- checking atm/land domains ---' + call seq_domain_check_grid(atmdom_a%data, lnddom_a%data, 'lat' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=maskl) + call seq_domain_check_grid(atmdom_a%data, lnddom_a%data, 'lon' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=maskl) + call seq_domain_check_grid(atmdom_a%data, lnddom_a%data, 'area', eps=eps_axarea, mpicom=mpicom_cplid, mask=maskl) + endif + + !------------------------------------------------------------------------------ + ! Check atm/ocn and atm/ice grid consistency (if samegrid) + !------------------------------------------------------------------------------ + + if (atm_present .and. ice_present .and. samegrid_ao) then + if (iamroot) write(logunit,F00) ' --- checking atm/ice domains ---' + call seq_domain_check_grid(atmdom_a%data, icedom_a%data, 'lat' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=maski) + call seq_domain_check_grid(atmdom_a%data, icedom_a%data, 'lon' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=maski) + call seq_domain_check_grid(atmdom_a%data, icedom_a%data, 'area', eps=eps_axarea, mpicom=mpicom_cplid, mask=maski) + endif + + if (atm_present .and. ocn_present .and. samegrid_ao) then + if (iamroot) write(logunit,F00) ' --- checking atm/ocn domains ---' + call seq_domain_check_grid(atmdom_a%data, ocndom_a%data, 'lat' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=masko) + call seq_domain_check_grid(atmdom_a%data, ocndom_a%data, 'lon' , eps=eps_axgrid, mpicom=mpicom_cplid, mask=masko) + call seq_domain_check_grid(atmdom_a%data, ocndom_a%data, 'area', eps=eps_axarea, mpicom=mpicom_cplid, mask=masko) + endif + + !------------------------------------------------------------------------------ + ! Check consistency of land fraction with ocean mask on grid + !------------------------------------------------------------------------------ + + if (atm_present) then + my_eps_frac = eps_frac + if (samegrid_ao) my_eps_frac = eps_frac_samegrid + if (.not. samegrid_al) my_eps_frac = eps_big + + if (iamroot) write(logunit,F00) ' --- checking fractions in domains ---' + dmaxi = 0.0_R8 + dmaxo = 0.0_R8 + do n = 1,atmsize + if (lnd_present .and. ice_present) then + diff = abs(1._R8 - fracl(n) - fraci(n)) + dmaxi = max(diff,dmaxi) + if (diff > my_eps_frac) then + write(logunit,*)'inconsistency between land fraction and sea ice fraction' + write(logunit,*)'n= ',n,' fracl= ',fracl(n),' fraci= ',fraci(n),' sum= ',fracl(n)+fraci(n) + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' inconsistency between land fraction and sea ice fraction') + end if + if ((1._R8-fraci(n)) > eps_frac .and. fracl(n) < eps_tiny) then + write(logunit,*)'inconsistency between land mask and sea ice mask' + write(logunit,*)'n= ',n,' fracl= ',fracl(n),' fraci= ',fraci(n) + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' inconsistency between land mask and sea ice mask') + end if + endif + if (lnd_present .and. ocn_present) then + diff = abs(1._R8 - fracl(n) - fraco(n)) + dmaxo = max(diff,dmaxo) + if (diff > my_eps_frac) then + write(logunit,*)'inconsistency between land fraction and ocn land fraction' + write(logunit,*)'n= ',n,' fracl= ',fracl(n),' fraco= ',fraco(n),' sum= ',fracl(n)+fraco(n) + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' inconsistency between land fraction and ocn land fraction') + end if + if ((1._R8-fraco(n)) > eps_frac .and. fracl(n) < eps_tiny) then + write(logunit,*)'inconsistency between land mask and ocn land mask' + write(logunit,*)'n= ',n,' fracl= ',fracl(n),' fraco= ',fraco(n) + call shr_sys_flush(logunit) + call shr_sys_abort(subname//' inconsistency between land mask and ocn land mask') + end if + endif + end do + if (iamroot) then + write(logunit,F02) ' maximum difference for ofrac sum ',dmaxo + write(logunit,F02) ' maximum difference for ifrac sum ',dmaxi + write(logunit,F02) ' maximum allowable difference for frac sum ',my_eps_frac + write(logunit,F02) ' maximum allowable tolerance for valid frac ',eps_frac + call shr_sys_flush(logunit) + end if + end if + + !------------------------------------------------------------------------------ + ! Clean up allocated memory + !------------------------------------------------------------------------------ + + if (atm_present .and. lnd_present) then + deallocate(fracl,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate fracl') + deallocate(maskl,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate maskl') + call mct_gGrid_clean(lnddom_a, rcode) + if(rcode /= 0) call shr_sys_abort(subname//' clean lnddom_a') + endif + + if (atm_present .and. ocn_present) then + deallocate(fraco,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate fraco') + deallocate(masko,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate masko') + call mct_gGrid_clean(ocndom_a, rcode) + if(rcode /= 0) call shr_sys_abort(subname//' clean ocndom_a') + endif + + if (atm_present .and. ice_present) then + deallocate(fraci,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate fraci') + deallocate(maski,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate maski') + call mct_gGrid_clean(icedom_a, rcode) + if(rcode /= 0) call shr_sys_abort(subname//' clean icedom_o') + endif + + if (ocn_present .and. ice_present) then + call mct_gGrid_clean(icedom_o, rcode) + if(rcode /= 0) call shr_sys_abort(subname//' clean icedom_o') + endif + + call shr_sys_flush(logunit) + + end subroutine seq_domain_check + +!=============================================================================== + + subroutine seq_domain_compare(dom1, dom2, mpicom, eps) + + !----------------------------------------------------------- + + ! Arguments + + type(mct_gGrid) , intent(in) :: dom1 + type(mct_gGrid) , intent(in) :: dom2 + integer(IN) , intent(in) :: mpicom + real(R8),optional, intent(in) :: eps ! error condition for compare + + ! Local variables + real(R8) :: leps + character(*),parameter :: F00 = "('(seq_domain_compare) ',4a)" + character(*),parameter :: F01 = "('(seq_domain_compare) ',a,i12,a)" + character(*),parameter :: F02 = "('(seq_domain_compare) ',2a,g23.15)" + character(*),parameter :: F0R = "('(seq_domain_compare) ',2A,2g23.15,A )" + character(*),parameter :: subName = '(seq_domain_compare) ' + + leps = eps_tiny + if (present(eps)) then + leps = eps + endif + + call seq_domain_check_grid(dom1%data, dom2%data, 'mask', eps=leps, mpicom=mpicom) + call seq_domain_check_grid(dom1%data, dom2%data, 'lat' , eps=leps, mpicom=mpicom) + call seq_domain_check_grid(dom1%data, dom2%data, 'lon' , eps=leps, mpicom=mpicom) + call seq_domain_check_grid(dom1%data, dom2%data, 'area', eps=leps, mpicom=mpicom) + + end subroutine seq_domain_compare + +!=============================================================================== + + subroutine seq_domain_check_fracmask(dom1) + + !----------------------------------------------------------- + + ! Arguments + + type(mct_aVect) , intent(in) :: dom1 + + ! Local variables + integer(in) :: n,npts,ndiff + integer(in) :: rcode + real(R8), pointer :: dmask(:) ! temporaries + real(R8), pointer :: dfrac(:) ! temporaries + + character(*),parameter :: F00 = "('(seq_domain_check_fracmask) ',4a)" + character(*),parameter :: F01 = "('(seq_domain_check_fracmask) ',a,i12,a)" + character(*),parameter :: F02 = "('(seq_domain_check_fracmask) ',2a,g23.15)" + character(*),parameter :: F0R = "('(seq_domain_check_fracmask) ',2A,2g23.15,A )" + character(*),parameter :: subName = '(seq_domain_check_fracmask) ' + !----------------------------------------------------------- + + npts = mct_aVect_lsize(dom1) + + allocate(dmask(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate dmask') + allocate(dfrac(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate dfrac') + + call mct_aVect_exportRAttr(dom1, 'mask', dmask, npts) + call mct_aVect_exportRAttr(dom1, 'frac', dfrac, npts) + + ndiff = 0 + do n = 1,npts + if (abs(dfrac(n)) > eps_tiny .and. abs(dmask(n)) < eps_tiny) then +!debug write(logunit,*)'n= ',n,' dfrac= ',dfrac(n),' dmask= ',dmask(n) + ndiff = ndiff + 1 + endif + enddo + + if (ndiff > 0) then + write(logunit,*) trim(subname)," ERROR: incompatible domain mask and frac values" + call shr_sys_flush(logunit) + call shr_sys_abort(subName//" incompatible domain mask and frac values") + endif + + deallocate(dmask,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate dmask') + deallocate(dfrac,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate dfrac') + + end subroutine seq_domain_check_fracmask + +!=============================================================================== + + subroutine seq_domain_check_grid(dom1, dom2, attr, eps, mpicom, mask) + + !----------------------------------------------------------- + + ! Arguments + + type(mct_aVect) , intent(in) :: dom1 + type(mct_aVect) , intent(in) :: dom2 + character(len=*), intent(in) :: attr ! grid attribute to compare + real(R8) , intent(in) :: eps ! error condition for compare + integer(IN) , intent(in) :: mpicom + real(R8) , intent(in), optional :: mask(:) + + ! Local variables + + integer(in) :: n,ndiff ! indices + integer(in) :: npts1,npts2,npts ! counters + integer(in) :: rcode ! error code + real(R8) :: diff,max_diff ! temporaries + real(R8) :: tot_diff ! maximum diff across all pes + integer(IN) :: ier ! error code + real(R8), pointer :: data1(:) ! temporaries + real(R8), pointer :: data2(:) ! temporaries + real(R8), pointer :: lmask(:) ! temporaries + logical :: iamroot ! local masterproc + + character(*),parameter :: F00 = "('(seq_domain_check_grid) ',4a)" + character(*),parameter :: F01 = "('(seq_domain_check_grid) ',a,i12,a)" + character(*),parameter :: F02 = "('(seq_domain_check_grid) ',2a,g23.15)" + character(*),parameter :: F0R = "('(seq_domain_check_grid) ',2A,2g23.15,A )" + character(*),parameter :: subName = '(seq_domain_check_grid) ' + !----------------------------------------------------------- + + call seq_comm_setptrs(CPLID,iamroot=iamroot) + + npts1 = mct_aVect_lsize(dom1) + npts2 = mct_aVect_lsize(dom2) + npts = npts1 + + if (npts1 == npts2) then + if (iamroot) write(logunit,F01) " the domain size is = ", npts + else + write(logunit,*) trim(subname)," domain size #1 = ", npts1 + write(logunit,*) trim(subname)," domain size #2 = ", npts2 + write(logunit,*) trim(subname)," ERROR: domain size mis-match" + call shr_sys_abort(subName//" ERROR: domain size mis-match") + end if + + allocate(data1(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate data1') + allocate(data2(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate data2') + allocate(lmask(npts),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate lmask') + + call mct_aVect_exportRAttr(dom1, trim(attr), data1, npts) + call mct_aVect_exportRAttr(dom2, trim(attr), data2, npts) + lmask = 1.0_R8 + if (present(mask)) then + if (size(mask) /= npts) then + call shr_sys_abort(subName//" ERROR: mask size mis-match") + endif + lmask = mask + endif + + ! --- adjust lons to address wraparound issues, we're assuming degree here! --- + + if (trim(attr) == "lon") then + do n = 1,npts + if (data2(n) > data1(n)) then + do while ( (data1(n)+360.0_R8) < (data2(n)+180.0_R8) ) ! longitude is periodic + data1(n) = data1(n) + 360.0_R8 + end do + else + do while ( (data2(n)+360.0_R8) < (data1(n)+180.0_R8) ) ! longitude is periodic + data2(n) = data2(n) + 360.0_R8 + end do + endif + enddo + endif + + ! Only check consistency where mask is greater than zero, if mask is present + + max_diff = 0.0_R8 + ndiff = 0 + do n=1,npts + if (lmask(n) > eps_tiny) then + diff = abs(data1(n)-data2(n)) + max_diff = max(max_diff,diff) + if (diff > eps) then + !debug write(logunit,*)'n= ',n,' data1= ',data1(n),' data2= ',data2(n),' diff= ',diff, ' eps= ',eps + ndiff = ndiff + 1 + endif + end if + end do + + call mpi_reduce(max_diff,tot_diff,1,MPI_REAL8,MPI_MAX,0,mpicom,ier) + if (iamroot) then + write(logunit,F02) " maximum difference for ",trim(attr),tot_diff + write(logunit,F02) " maximum allowable difference for ",trim(attr),eps + call shr_sys_flush(logunit) + endif + call mpi_barrier(mpicom,ier) + + if (ndiff > 0) then + write(logunit,*) trim(subname)," ERROR: incompatible domain grid coordinates" + call shr_sys_flush(logunit) + call shr_sys_abort(subName//" incompatible domain grid coordinates") + endif + + deallocate(data1,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate data1') + deallocate(data2,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate data2') + deallocate(lmask,stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' deallocate lmask') + + end subroutine seq_domain_check_grid + +!=============================================================================== + + subroutine seq_domain_areafactinit(domain, mdl2drv, drv2mdl, & + samegrid, mpicom, iamroot, comment) + !----------------------------------------------------------- + ! + ! Arguments + ! + type(mct_gGrid) , pointer :: domain ! component domain on component pes + real(R8) , pointer :: mdl2drv(:) ! comp->cpl factor on component pes + real(R8) , pointer :: drv2mdl(:) ! cpl->comp factor on component pes + logical , intent(in) :: samegrid ! true => two grids are same + integer , intent(in) :: mpicom ! mpi communicator on component pes + logical , intent(in) :: iamroot + character(len=*) , optional,intent(in) :: comment + ! + ! Local variables + ! + integer :: j1,j2,m1,n,rcode + integer :: gridsize,m2dsize,d2msize + real(R8) :: rmin1,rmax1,rmin,rmax + real(R8) :: rmask,rarea,raream + character(cl) :: lcomment + character(len=*),parameter :: subName = '(seq_domain_areafactinit) ' + character(len=*),parameter :: F0R = "(2A,2g23.15,A )" + ! + !----------------------------------------------------------- + + lcomment = '' + if (present(comment)) lcomment = comment + + ! get sizes + + gridsize = mct_gGrid_lsize(domain) + allocate(drv2mdl(gridsize),mdl2drv(gridsize),stat=rcode) + if(rcode /= 0) call shr_sys_abort(subname//' allocate area correction factors') + + j1 = mct_gGrid_indexRA(domain,"area" ,dieWith=subName) + j2 = mct_gGrid_indexRA(domain,"aream" ,dieWith=subName) + m1 = mct_gGrid_indexRA(domain,"mask" ,dieWith=subName) + + mdl2drv(:)=1.0_R8 + drv2mdl(:)=1.0_R8 + + if (samegrid) then + ! default 1.0 + else + do n=1,gridsize + rmask = domain%data%rAttr(m1,n) + rarea = domain%data%rAttr(j1,n) + raream = domain%data%rAttr(j2,n) + if ( abs(rmask) >= 1.0e-06) then + if (rarea * raream /= 0.0_R8) then + mdl2drv(n) = rarea/raream + drv2mdl(n) = 1.0_R8/mdl2drv(n) + !if (mdl2drv(n) > 10.0 .or. mdl2drv(n) < 0.1) then + ! write(logunit,*) trim(subname),' WARNING area,aream= ', & + ! domain%data%rAttr(j1,n),domain%data%rAttr(j2,n),' in ',n,gridsize + !endif + else + write(logunit,*) trim(subname),' ERROR area,aream= ', & + rarea,raream,' in ',n,gridsize + call shr_sys_flush(logunit) + call shr_sys_abort() + endif + endif + enddo + end if + + rmin1 = minval(mdl2drv) + rmax1 = maxval(mdl2drv) + call shr_mpi_min(rmin1,rmin,mpicom) + call shr_mpi_max(rmax1,rmax,mpicom) + if (iamroot) write(logunit,F0R) trim(subname),' : min/max mdl2drv ',rmin,rmax,trim(lcomment) + + rmin1 = minval(drv2mdl) + rmax1 = maxval(drv2mdl) + call shr_mpi_min(rmin1,rmin,mpicom) + call shr_mpi_max(rmax1,rmax,mpicom) + if (iamroot) write(logunit,F0R) trim(subname),' : min/max drv2mdl ',rmin,rmax,trim(lcomment) + if (iamroot) call shr_sys_flush(logunit) + + end subroutine seq_domain_areafactinit + +!=============================================================================== + +end module seq_domain_mct diff --git a/driver-mct/main/seq_flux_mct.F90 b/driver-mct/main/seq_flux_mct.F90 new file mode 100644 index 000000000000..1b26aa2442c1 --- /dev/null +++ b/driver-mct/main/seq_flux_mct.F90 @@ -0,0 +1,1502 @@ +module seq_flux_mct + + use shr_kind_mod, only: r8 => shr_kind_r8, in=>shr_kind_in + use shr_sys_mod, only: shr_sys_abort + use shr_flux_mod, only: shr_flux_atmocn, shr_flux_atmocn_diurnal + use shr_orb_mod, only: shr_orb_params, shr_orb_cosz, shr_orb_decl + use shr_mct_mod, only: shr_mct_queryConfigFile, shr_mct_sMatReaddnc + + use mct_mod + use seq_flds_mod + use seq_comm_mct + use seq_infodata_mod + + use component_type_mod + + implicit none + private + save + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public seq_flux_init_mct + public seq_flux_initexch_mct + + public seq_flux_ocnalb_mct + + public seq_flux_atmocn_mct + public seq_flux_atmocnexch_mct + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + real(r8), pointer :: lats(:) ! latitudes (degrees) + real(r8), pointer :: lons(:) ! longitudes (degrees) + integer(in),allocatable :: mask(:) ! ocn domain mask: 0 <=> inactive cell + integer(in),allocatable :: emask(:) ! ocn mask on exchange grid decomp + + real(r8), allocatable :: uocn (:) ! ocn velocity, zonal + real(r8), allocatable :: vocn (:) ! ocn velocity, meridional + real(r8), allocatable :: tocn (:) ! ocean temperature + real(r8), allocatable :: zbot (:) ! atm level height + real(r8), allocatable :: ubot (:) ! atm velocity, zonal + real(r8), allocatable :: vbot (:) ! atm velocity, meridional + real(r8), allocatable :: thbot(:) ! atm potential T + real(r8), allocatable :: shum (:) ! atm specific humidity + real(r8), allocatable :: shum_16O (:) ! atm H2O tracer + real(r8), allocatable :: shum_HDO (:) ! atm HDO tracer + real(r8), allocatable :: shum_18O (:) ! atm H218O tracer + real(r8), allocatable :: roce_16O (:) ! ocn H2O ratio + real(r8), allocatable :: roce_HDO (:) ! ocn HDO ratio + real(r8), allocatable :: roce_18O (:) ! ocn H218O ratio + real(r8), allocatable :: dens (:) ! atm density + real(r8), allocatable :: tbot (:) ! atm bottom surface T + real(r8), allocatable :: sen (:) ! heat flux: sensible + real(r8), allocatable :: lat (:) ! heat flux: latent + real(r8), allocatable :: lwup (:) ! lwup over ocean + real(r8), allocatable :: evap (:) ! water flux: evaporation + real(r8), allocatable :: evap_16O (:) !H2O flux: evaporation + real(r8), allocatable :: evap_HDO (:) !HDO flux: evaporation + real(r8), allocatable :: evap_18O (:) !H218O flux: evaporation + real(r8), allocatable :: taux (:) ! wind stress, zonal + real(r8), allocatable :: tauy (:) ! wind stress, meridional + real(r8), allocatable :: tref (:) ! diagnostic: 2m ref T + real(r8), allocatable :: qref (:) ! diagnostic: 2m ref Q + real(r8), allocatable :: duu10n(:) ! diagnostic: 10m wind speed squared + + real(r8), allocatable :: fswpen (:) ! fraction of sw penetrating ocn surface layer + real(r8), allocatable :: ocnsal (:) ! ocean salinity + real(r8), allocatable :: uGust (:) ! wind gust + real(r8), allocatable :: lwdn (:) ! long wave, downward + real(r8), allocatable :: swdn (:) ! short wave, downward + real(r8), allocatable :: swup (:) ! short wave, upward + real(r8), allocatable :: prec (:) ! precip + real(r8), allocatable :: prec_gust (:) ! atm precip for convective gustiness (kg/m^3) + + ! Diurnal cycle variables wrt flux + + real(r8), allocatable :: tbulk (:) ! diagnostic: ocn bulk T + real(r8), allocatable :: tskin (:) ! diagnostic: ocn skin T + real(r8), allocatable :: tskin_night(:) ! diagnostic: ocn skin T + real(r8), allocatable :: tskin_day (:) ! diagnostic: ocn skin T + real(r8), allocatable :: cSkin (:) ! diagnostic: ocn cool skin + real(r8), allocatable :: cSkin_night(:) ! diagnostic: ocn cool skin + real(r8), allocatable :: warm (:) ! diagnostic: ocn warming + real(r8), allocatable :: salt (:) ! diagnostic: ocn salting + real(r8), allocatable :: speed (:) ! diagnostic: ocn speed + real(r8), allocatable :: regime (:) ! diagnostic: ocn regime + real(r8), allocatable :: warmMax (:) ! diagnostic: ocn warming, max daily value + real(r8), allocatable :: windMax (:) ! diagnostic: ocn wind , max daily value + real(r8), allocatable :: QsolAvg (:) ! diagnostic: ocn Qsol , daily avg + real(r8), allocatable :: windAvg (:) ! diagnostic: ocn wind , daily avg + real(r8), allocatable :: warmMaxInc (:) ! diagnostic: ocn warming, max daily value, increment + real(r8), allocatable :: windMaxInc (:) ! diagnostic: ocn wind , max daily value, increment + real(r8), allocatable :: qSolInc (:) ! diagnostic: ocn Qsol , daily avg, increment + real(r8), allocatable :: windInc (:) ! diagnostic: ocn wind , daily avg, increment + real(r8), allocatable :: nInc (:) ! diagnostic: a/o flux , increment + + real(r8), allocatable :: ustar(:) ! saved ustar + real(r8), allocatable :: re (:) ! saved re + real(r8), allocatable :: ssq (:) ! saved sq + + ! Conversion from degrees to radians + + real(r8),parameter :: const_pi = SHR_CONST_PI ! pi + real(r8),parameter :: const_deg2rad = const_pi/180.0_r8 ! deg to rads + + ! Coupler field indices + + integer :: index_a2x_Sa_z + integer :: index_a2x_Sa_u + integer :: index_a2x_Sa_v + integer :: index_a2x_Sa_tbot + integer :: index_a2x_Sa_ptem + integer :: index_a2x_Sa_shum + integer :: index_a2x_Sa_shum_16O + integer :: index_a2x_Sa_shum_HDO + integer :: index_a2x_Sa_shum_18O + integer :: index_a2x_Sa_dens + integer :: index_a2x_Faxa_swndr + integer :: index_a2x_Faxa_swndf + integer :: index_a2x_Faxa_swvdr + integer :: index_a2x_Faxa_swvdf + integer :: index_a2x_Faxa_lwdn + integer :: index_a2x_Faxa_rainc + integer :: index_a2x_Faxa_rainl + integer :: index_a2x_Faxa_snowc + integer :: index_a2x_Faxa_snowl + integer :: index_o2x_So_t + integer :: index_o2x_So_u + integer :: index_o2x_So_v + integer :: index_o2x_So_fswpen + integer :: index_o2x_So_s + integer :: index_o2x_So_roce_16O + integer :: index_o2x_So_roce_HDO + integer :: index_o2x_So_roce_18O + integer :: index_xao_So_tref + integer :: index_xao_So_qref + integer :: index_xao_So_avsdr + integer :: index_xao_So_avsdf + integer :: index_xao_So_anidr + integer :: index_xao_So_anidf + integer :: index_xao_Faox_taux + integer :: index_xao_Faox_tauy + integer :: index_xao_Faox_lat + integer :: index_xao_Faox_sen + integer :: index_xao_Faox_evap + integer :: index_xao_Faox_evap_16O + integer :: index_xao_Faox_evap_HDO + integer :: index_xao_Faox_evap_18O + integer :: index_xao_Faox_lwup + integer :: index_xao_Faox_swdn + integer :: index_xao_Faox_swup + integer :: index_xao_So_ustar + integer :: index_xao_So_re + integer :: index_xao_So_ssq + integer :: index_xao_So_duu10n + integer :: index_xao_So_u10 + integer :: index_xao_So_fswpen + integer :: index_xao_So_warm_diurn + integer :: index_xao_So_salt_diurn + integer :: index_xao_So_speed_diurn + integer :: index_xao_So_regime_diurn + integer :: index_xao_So_tskin_diurn + integer :: index_xao_So_tskin_day_diurn + integer :: index_xao_So_tskin_night_diurn + integer :: index_xao_So_cskin_diurn + integer :: index_xao_So_cskin_night_diurn + integer :: index_xao_So_tbulk_diurn + integer :: index_xao_So_warmmax_diurn + integer :: index_xao_So_windmax_diurn + integer :: index_xao_So_qsolavg_diurn + integer :: index_xao_So_windavg_diurn + integer :: index_xao_So_warmmaxinc_diurn + integer :: index_xao_So_windmaxinc_diurn + integer :: index_xao_So_qsolinc_diurn + integer :: index_xao_So_windinc_diurn + integer :: index_xao_So_ninc_diurn + + character(len=16) :: fluxsetting = 'unknown' + character(len=*),parameter :: fluxsetting_atmocn = 'atmocn' + character(len=*),parameter :: fluxsetting_exchange = 'exchange' + + !--- for exchange grid --- + type(mct_rearr) :: Re_a2e, Re_e2a, Re_o2e, Re_e2o ! atm/ocn/exch rearrangers + type(mct_sMat ) :: sMata2o, sMato2a ! decomp sMat + type(mct_gsMap) :: gsmap_ae, gsmap_oe ! gsmaps for atm/ocn on exch grid + integer(in) :: nloc_a2o,nloc_o2a,nloc_o,nloc_a,nloc_ae,nloc_oe + +!=============================================================================== +contains +!=============================================================================== + + subroutine seq_flux_init_mct(comp, fractions) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(component_type), intent(in) :: comp + type(mct_aVect), intent(in) :: fractions + ! + ! Local variables + ! + type(mct_gsMap), pointer :: gsMap + type(mct_gGrid), pointer :: dom + integer(in) :: nloc + integer :: ko,ki ! fractions indices + integer :: ier + real(r8), pointer :: rmask(:) ! ocn domain mask + character(*),parameter :: subName = '(seq_flux_init_mct) ' + !----------------------------------------------------------------------- + + gsmap => component_get_gsmap_cx(comp) + dom => component_get_dom_cx(comp) + + nloc = mct_avect_lsize(dom%data) + + ! Input fields atm + allocate( zbot(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate zbot',ier) + zbot = 0.0_r8 + allocate( ubot(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ubot',ier) + ubot = 0.0_r8 + allocate( vbot(nloc)) + if(ier/=0) call mct_die(subName,'allocate vbot',ier) + vbot = 0.0_r8 + allocate(thbot(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate thbot',ier) + thbot = 0.0_r8 + allocate(shum(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum',ier) + shum = 0.0_r8 + allocate(shum_16O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_16O',ier) + shum_16O = 0.0_r8 + allocate(shum_HDO(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_HDO',ier) + shum_HDO = 0.0_r8 + allocate(shum_18O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_18O',ier) + shum_18O = 0.0_r8 + allocate(dens(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate dens',ier) + dens = 0.0_r8 + allocate(tbot(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tbot',ier) + tbot = 0.0_r8 + allocate(ustar(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ustar',ier) + ustar = 0.0_r8 + allocate(re(nloc), stat=ier) + if(ier/=0) call mct_die(subName,'allocate re',ier) + re = 0.0_r8 + allocate(ssq(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ssq',ier) + ssq = 0.0_r8 + allocate( uocn(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate uocn',ier) + uocn = 0.0_r8 + allocate( vocn(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate vocn',ier) + vocn = 0.0_r8 + allocate( tocn(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tocn',ier) + tocn = 0.0_r8 + allocate(roce_16O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate roce_16O',ier) + roce_16O = 0.0_r8 + allocate(roce_HDO(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate roce_HDO',ier) + roce_HDO = 0.0_r8 + allocate(roce_18O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate roce_18O',ier) + roce_18O = 0.0_r8 + + ! Output fields + allocate(sen (nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate sen',ier) + sen = 0.0_r8 + allocate(lat (nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate lat',ier) + lat = 0.0_r8 + allocate(evap(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap',ier) + evap = 0.0_r8 + allocate(evap_16O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_16O',ier) + evap_16O = 0.0_r8 + allocate(evap_HDO(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_HDO',ier) + evap_HDO = 0.0_r8 + allocate(evap_18O(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_18O',ier) + evap_18O = 0.0_r8 + allocate(lwup(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate lwup',ier) + lwup = 0.0_r8 + allocate(taux(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate taux',ier) + taux = 0.0_r8 + allocate(tauy(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tauy',ier) + tauy = 0.0_r8 + allocate(tref(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tref',ier) + tref = 0.0_r8 + allocate(qref(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate qref',ier) + qref = 0.0_r8 + allocate(duu10n(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate duu10n',ier) + duu10n = 0.0_r8 + + !--- flux_diurnal cycle flux fields --- + allocate(uGust(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate uGust',ier) + uGust = 0.0_r8 + allocate(lwdn(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate lwdn',ier) + lwdn = 0.0_r8 + allocate(swdn(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate swdn',ier) + swdn = 0.0_r8 + allocate(swup(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate swup',ier) + swup = 0.0_r8 + allocate(prec(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate prec',ier) + prec = 0.0_r8 + allocate(prec_gust(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate prec_gust',ier) + prec_gust = 0.0_r8 + allocate(fswpen(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate fswpen',ier) + fswpen = 0.0_r8 + allocate(ocnsal(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ocnsal',ier) + ocnsal = 0.0_r8 + + allocate(tbulk(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tbulk',ier) + tbulk = 0.0_r8 + allocate(tskin(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tskin',ier) + tskin = 0.0_r8 + allocate(tskin_day(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tskin_day',ier) + tskin_day = 0.0_r8 + allocate(tskin_night(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tskin_night',ier) + tskin_night = 0.0_r8 + allocate(cskin(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate cskin',ier) + cskin = 0.0_r8 + allocate(cskin_night(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate cskin_night',ier) + cskin_night = 0.0_r8 + + allocate(warm(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate warm',ier) + warm = 0.0_r8 + allocate(salt(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate salt',ier) + salt = 0.0_r8 + allocate(speed(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate speed',ier) + speed = 0.0_r8 + allocate(regime(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate regime',ier) + regime = 0.0_r8 + allocate(warmMax(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate warmMax',ier) + warmMax = 0.0_r8 + allocate(windMax(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate windMax',ier) + windMax = 0.0_r8 + allocate(qSolAvg(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate qSolAvg',ier) + qSolAvg = 0.0_r8 + allocate(windAvg(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate windAvg',ier) + windAvg = 0.0_r8 + + allocate(warmMaxInc(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate warmMaxInc',ier) + warmMaxInc = 0.0_r8 + allocate(windMaxInc(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate windMaxInc',ier) + windMaxInc = 0.0_r8 + allocate(qSolInc(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate qSolInc',ier) + qSolInc = 0.0_r8 + allocate(windInc(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate windInc',ier) + windInc = 0.0_r8 + allocate(nInc (nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate nInc',ier) + nInc = 0.0_r8 + + ! Grid fields + allocate( lats(nloc),stat=ier ) + if(ier/=0) call mct_die(subName,'allocate lats',ier) + lats = 0.0_r8 + allocate( lons(nloc),stat=ier ) + if(ier/=0) call mct_die(subName,'allocate lons',ier) + lons = 0.0_r8 + allocate( emask(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate emask',ier) + emask = 0.0_r8 + allocate(mask(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate mask',ier) + mask = 0.0_r8 + + ! Get lat, lon, mask, which is time-invariant + allocate(rmask(nloc),stat=ier) + if(ier/=0) call mct_die(subName,'allocate rmask',ier) + call mct_gGrid_exportRAttr(dom, 'lat' , lats , nloc) + call mct_gGrid_exportRAttr(dom, 'lon' , lons , nloc) + + ! setup the compute mask. + ! prefer to compute just where ocean exists, so setup a mask here. + ! this could be run with either the ocean or atm grid so need to be careful. + ! really want the ocean mask on ocean grid or ocean mask mapped to atm grid, + ! but do not have access to the ocean mask mapped to the atm grid. + ! the dom mask is a good place to start, on ocean grid, it should be what we want, + ! on the atm grid, it's just all 1's so not very useful. + ! next look at ofrac+ifrac in fractions. want to compute on all non-land points. + ! using ofrac alone will exclude points that are currently all sea ice but that later + ! could be less that 100% covered in ice. + + ! default compute everywhere, then "turn off" gridcells + mask = 1 + + ! use domain mask first + call mct_gGrid_exportRAttr(dom, 'mask', rmask, nloc) + where (rmask < 0.5_r8) mask = 0 ! like nint + deallocate(rmask) + + ! then check ofrac + ifrac + ko = mct_aVect_indexRA(fractions,"ofrac") + ki = mct_aVect_indexRA(fractions,"ifrac") + where (fractions%rAttr(ko,:)+fractions%rAttr(ki,:) <= 0.0_r8) mask(:) = 0 + + emask = mask + + fluxsetting = trim(fluxsetting_atmocn) + + end subroutine seq_flux_init_mct + +!=============================================================================== + + subroutine seq_flux_initexch_mct(atm, ocn, mpicom_cplid, cplid) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(component_type), intent(in) :: atm + type(component_type), intent(in) :: ocn + integer(in) , intent(in) :: mpicom_cplid + integer(in) , intent(in) :: cplid + ! + ! Local variables + ! + type(mct_gsMap), pointer :: gsmap_a + type(mct_gGrid), pointer :: dom_a + type(mct_gsMap), pointer :: gsmap_o + type(mct_gGrid), pointer :: dom_o + integer(in) :: kw,ka,ko,iw,ia,io,n + character(len=128) :: strat + integer :: ier + integer :: mytask + integer(in) :: kmsk ! field indices + character(len=128) :: ConfigFileName ! config file to read + character(len=128) :: MapLabel ! map name + character(len=128) :: MapTypeLabel ! map type + character(len=256) :: fileName + character(len=1) :: maptype + character(len=3) :: Smaptype + type(mct_aVect) :: avdom_oe + type(mct_list) :: sort_keys + character(*),parameter :: subName = '(seq_flux_initexch_mct) ' + !----------------------------------------------------------------------- + + gsmap_a => component_get_gsmap_cx(atm) ! gsmap_ax + gsmap_o => component_get_gsmap_cx(ocn) ! gsmap_ox + dom_a => component_get_dom_cx(atm) ! dom_ax + dom_o => component_get_dom_cx(ocn) ! dom_ox + + call shr_mpi_commrank(mpicom_cplid, mytask) + + !--- Get mapping file info + do n = 1,2 + ConfigFileName = "seq_maps.rc" + if (n == 1) then + MapLabel = "atm2ocn_fmapname:" + MapTypeLabel = "atm2ocn_fmaptype:" + elseif (n == 2) then + MapLabel = "ocn2atm_fmapname:" + MapTypeLabel = "ocn2atm_fmaptype:" + else + call shr_sys_abort(trim(subname)//' do error1') + endif + + call shr_mct_queryConfigFile(mpicom_cplid, ConfigFilename, & + trim(MapLabel),fileName,trim(MapTypeLabel),maptype) + + !--- hardwire decomposition to gsmap_o + if (n == 1) then + Smaptype = "src" + call shr_mct_sMatReaddnc(sMata2o, gsmap_a, gsmap_o, Smaptype, & + filename=fileName, mytask=mytask, mpicom=mpicom_cplid) + elseif (n == 2) then + Smaptype = "dst" + call shr_mct_sMatReaddnc(sMato2a, gsmap_o, gsmap_a, Smaptype, & + filename=fileName, mytask=mytask, mpicom=mpicom_cplid) + else + call shr_sys_abort(trim(subname)//' do error2') + endif + + enddo + + !--- the two mapping files must have their local indices in identical order + !--- sort the global indices as a starting point + + call mct_list_init(sort_keys,'grow:gcol') + call mct_sMat_SortPermute(sMata2o,sort_keys) + call mct_list_clean(sort_keys) + call mct_list_init(sort_keys,'gcol:grow') + call mct_sMat_SortPermute(sMato2a,sort_keys) + call mct_list_clean(sort_keys) + + !--- now check that they are sorted properly + + nloc_a2o= mct_sMat_lsize(sMata2o) + nloc_o2a= mct_sMat_lsize(sMato2a) + + if (nloc_a2o /= nloc_o2a) then + write(logunit,*) trim(subname),' ERROR: sMat sizes',nloc_a2o,nloc_o2a + call shr_sys_abort(trim(subname)//' ERROR in sMat sizes') + endif + ko = mct_sMat_indexIA(sMata2o,'grow') ! local row (dst) index + ka = mct_sMat_indexIA(sMato2a,'gcol') ! local column (src) index + do n = 1,nloc_a2o + io = sMata2o%data%iAttr(ko,n) + ia = sMato2a%data%iAttr(ka,n) + if (io /= ia) then + write(logunit,*) trim(subname),' ERROR: sMat indices1 ',io,ia + call shr_sys_abort(trim(subname)//' ERROR in sMat indices1') + endif + enddo + ko = mct_sMat_indexIA(sMata2o,'gcol') ! local column (src) index + ka = mct_sMat_indexIA(sMato2a,'grow') ! local row (dst) index + do n = 1,nloc_a2o + io = sMata2o%data%iAttr(ko,n) + ia = sMato2a%data%iAttr(ka,n) + if (io /= ia) then + write(logunit,*) trim(subname),' ERROR: sMat indices2 ',io,ia + call shr_sys_abort(trim(subname)//' ERROR in sMat indices2') + endif + enddo + + !--- instantiate/create/compute various datatypes + + call mct_sMat_2XgsMap(sMata2o , gsmap_ae, 0, mpicom_cplid, cplid) + call mct_sMat_2YgsMap(sMata2o , gsmap_oe, 0, mpicom_cplid, cplid) + + call mct_rearr_init(gsmap_a , gsmap_ae, mpicom_cplid, Re_a2e) + call mct_rearr_init(gsmap_ae , gsmap_a, mpicom_cplid, Re_e2a) + call mct_rearr_init(gsmap_o , gsmap_oe, mpicom_cplid, Re_o2e) + call mct_rearr_init(gsmap_oe , gsmap_o, mpicom_cplid, Re_e2o) + + call mct_sMat_g2lMat(sMata2o , gsmap_ae, 'column',mpicom_cplid) + call mct_sMat_g2lMat(sMata2o , gsmap_oe, 'row', mpicom_cplid) + call mct_sMat_g2lMat(sMato2a , gsmap_ae, 'row', mpicom_cplid) + call mct_sMat_g2lMat(sMato2a , gsmap_oe, 'column',mpicom_cplid) + + nloc_a = mct_gsmap_lsize(gsmap_a , mpicom_cplid) + nloc_o = mct_gsmap_lsize(gsmap_o , mpicom_cplid) + nloc_ae = mct_gsmap_lsize(gsmap_ae , mpicom_cplid) + nloc_oe = mct_gsmap_lsize(gsmap_oe , mpicom_cplid) + + call mct_gsmap_clean(gsmap_ae) + call mct_gsmap_clean(gsmap_oe) + + ! Input fields atm + allocate( emask(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate emask',ier) + allocate( zbot(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate zbot',ier) + allocate( ubot(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ubot',ier) + allocate( vbot(nloc_a2o)) + if(ier/=0) call mct_die(subName,'allocate vbot',ier) + allocate(thbot(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate thbot',ier) + allocate(shum(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum',ier) + allocate(shum_16O(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_16O',ier) + allocate(shum_HDO(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_HDO',ier) + allocate(shum_18O(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate shum_18O',ier) + allocate(dens(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate dens',ier) + allocate(tbot(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tbot',ier) + allocate(ustar(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ustar',ier) + allocate(re(nloc_a2o), stat=ier) + if(ier/=0) call mct_die(subName,'allocate re',ier) + allocate(ssq(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate ssq',ier) + allocate( uocn(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate uocn',ier) + allocate( vocn(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate vocn',ier) + allocate( tocn(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tocn',ier) + + ! Output fields + allocate(sen (nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate sen',ier) + allocate(lat (nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate lat',ier) + allocate(evap(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap',ier) + allocate(evap_16O(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_16O',ier) + allocate(evap_HDO(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_HDO',ier) + allocate(evap_18O(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate evap_18O',ier) + allocate(lwup(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate lwup',ier) + allocate(taux(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate taux',ier) + allocate(tauy(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tauy',ier) + allocate(tref(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate tref',ier) + allocate(qref(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate qref',ier) + allocate(duu10n(nloc_a2o),stat=ier) + if(ier/=0) call mct_die(subName,'allocate duu10n',ier) + + ! set emask + + call mct_avect_init(avdom_oe,dom_o%data,lsize=nloc_oe) + call mct_rearr_rearrange(dom_o%data, avdom_oe, Re_o2e, VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + ko = mct_sMat_indexIA(sMata2o,'lrow') ! local dst index + kmsk = mct_aVect_indexRA(avdom_oe,"mask",dieWith=subName) + do n = 1,nloc_a2o + io = sMata2o%data%iAttr(ko,n) + emask(n) = nint(avdom_oe%rAttr(kmsk,io)) + if (emask(n) == 0) then + write(logunit,*) trim(subname),' ERROR: weights use masked ocean value' + call shr_sys_abort(trim(subname)//' ERROR: weights use masked ocean value') + endif + enddo + + call mct_aVect_clean(avdom_oe) + + fluxsetting = trim(fluxsetting_exchange) + + end subroutine seq_flux_initexch_mct + +!=============================================================================== + + subroutine seq_flux_ocnalb_mct( infodata, ocn, a2x_o, fractions_o, xao_o ) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_infodata_type) , intent(in) :: infodata + type(component_type) , intent(in) :: ocn + type(mct_aVect) , intent(in) :: a2x_o + type(mct_aVect) , intent(inout) :: fractions_o + type(mct_aVect) , intent(inout) :: xao_o + ! + ! Local variables + ! + type(mct_gGrid), pointer :: dom_o + logical :: flux_albav ! flux avg option + integer(in) :: n,i ! indices + real(r8) :: rlat ! gridcell latitude in radians + real(r8) :: rlon ! gridcell longitude in radians + real(r8) :: cosz ! Cosine of solar zenith angle + real(r8) :: eccen ! Earth orbit eccentricity + real(r8) :: mvelpp ! Earth orbit + real(r8) :: lambm0 ! Earth orbit + real(r8) :: obliqr ! Earth orbit + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: calday ! calendar day including fraction, at 0e + real(r8) :: nextsw_cday ! calendar day of next atm shortwave + real(r8) :: anidr ! albedo: near infrared, direct + real(r8) :: avsdr ! albedo: visible , direct + real(r8) :: anidf ! albedo: near infrared, diffuse + real(r8) :: avsdf ! albedo: visible , diffuse + real(r8) :: swdnc ! temporary swdn + real(r8) :: swupc ! temporary swup + integer(in) :: ID ! comm ID + integer(in) :: ier ! error code + integer(in) :: kx,kr ! fractions indices + integer(in) :: klat,klon,kmsk ! field indices + logical :: update_alb ! was albedo updated + logical,save :: first_call = .true. + ! + real(r8),parameter :: albdif = 0.06_r8 ! 60 deg reference albedo, diffuse + real(r8),parameter :: albdir = 0.07_r8 ! 60 deg reference albedo, direct + character(*),parameter :: subName = '(seq_flux_ocnalb_mct) ' + ! + !----------------------------------------------------------------------- + + dom_o => component_get_dom_cx(ocn) ! dom_ox + + call seq_infodata_getData(infodata , & + flux_albav=flux_albav) + + ! Determine indices + + update_alb = .false. + + if (first_call) then + index_xao_So_anidr = mct_aVect_indexRA(xao_o,'So_anidr') + index_xao_So_anidf = mct_aVect_indexRA(xao_o,'So_anidf') + index_xao_So_avsdr = mct_aVect_indexRA(xao_o,'So_avsdr') + index_xao_So_avsdf = mct_aVect_indexRA(xao_o,'So_avsdf') + index_xao_Faox_swdn = mct_aVect_indexRA(xao_o,'Faox_swdn') + index_xao_Faox_swup = mct_aVect_indexRA(xao_o,'Faox_swup') + + index_a2x_Faxa_swndr = mct_aVect_indexRA(a2x_o,'Faxa_swndr') + index_a2x_Faxa_swndf = mct_aVect_indexRA(a2x_o,'Faxa_swndf') + index_a2x_Faxa_swvdr = mct_aVect_indexRA(a2x_o,'Faxa_swvdr') + index_a2x_Faxa_swvdf = mct_aVect_indexRA(a2x_o,'Faxa_swvdf') + + nloc_o = mct_ggrid_lsize(dom_o) + klat = mct_gGrid_indexRA(dom_o,"lat" ,dieWith=subName) + klon = mct_gGrid_indexRA(dom_o,"lon" ,dieWith=subName) + allocate( lats(nloc_o),stat=ier ) + if(ier/=0) call mct_die(subName,'allocate lats',ier) + allocate( lons(nloc_o),stat=ier ) + if(ier/=0) call mct_die(subName,'allocate lons',ier) + do n = 1,nloc_o + lats(n) = dom_o%data%rAttr(klat,n) + lons(n) = dom_o%data%rAttr(klon,n) + enddo + first_call = .false. + endif + + if (flux_albav) then + + do n=1,nloc_o + anidr = albdir + avsdr = albdir + anidf = albdif + avsdf = albdif + + ! Albedo is now function of latitude (will be new implementation) + !rlat = const_deg2rad * lats(n) + !anidr = 0.069_r8 - 0.011_r8 * cos(2._r8 * rlat) + !avsdr = anidr + !anidf = anidr + !avsdf = anidr + + xao_o%rAttr(index_xao_So_avsdr,n) = avsdr + xao_o%rAttr(index_xao_So_anidr,n) = anidr + xao_o%rAttr(index_xao_So_avsdf,n) = avsdf + xao_o%rAttr(index_xao_So_anidf,n) = anidf + end do + update_alb = .true. + + else + + !--- flux_atmocn needs swdn & swup = swdn*(-albedo) + !--- swdn & albedos are time-aligned BEFORE albedos get updated below --- + do n=1,nloc_o + avsdr = xao_o%rAttr(index_xao_So_avsdr,n) + anidr = xao_o%rAttr(index_xao_So_anidr,n) + avsdf = xao_o%rAttr(index_xao_So_avsdf,n) + anidf = xao_o%rAttr(index_xao_So_anidf,n) + swupc = a2x_o%rAttr(index_a2x_Faxa_swndr,n)*(-anidr) & + & + a2x_o%rAttr(index_a2x_Faxa_swndf,n)*(-anidf) & + & + a2x_o%rAttr(index_a2x_Faxa_swvdr,n)*(-avsdr) & + & + a2x_o%rAttr(index_a2x_Faxa_swvdf,n)*(-avsdf) + swdnc = a2x_o%rAttr(index_a2x_Faxa_swndr,n) & + & + a2x_o%rAttr(index_a2x_Faxa_swndf,n) & + & + a2x_o%rAttr(index_a2x_Faxa_swvdr,n) & + & + a2x_o%rAttr(index_a2x_Faxa_swvdf,n) + if ( anidr == 1.0_r8 ) then ! dark side of earth + swupc = 0.0_r8 + swdnc = 0.0_r8 + end if + xao_o%rAttr(index_xao_Faox_swdn,n) = swdnc + xao_o%rAttr(index_xao_Faox_swup,n) = swupc + end do + + ! Solar declination + ! Will only do albedo calculation if nextsw_cday is not -1. + + call seq_infodata_GetData(infodata,nextsw_cday=nextsw_cday,orb_eccen=eccen, & + orb_mvelpp=mvelpp, orb_lambm0=lambm0, orb_obliqr=obliqr) + if (nextsw_cday >= -0.5_r8) then + calday = nextsw_cday + call shr_orb_decl(calday, eccen, mvelpp,lambm0, obliqr, delta, eccf) + ! Compute albedos + do n=1,nloc_o + rlat = const_deg2rad * lats(n) + rlon = const_deg2rad * lons(n) + cosz = shr_orb_cosz( calday, rlat, rlon, delta ) + if (cosz > 0.0_r8) then !--- sun hit -- + anidr = (.026_r8/(cosz**1.7_r8 + 0.065_r8)) + & + (.150_r8*(cosz - 0.100_r8 ) * & + (cosz - 0.500_r8 ) * & + (cosz - 1.000_r8 ) ) + avsdr = anidr + anidf = albdif + avsdf = albdif + else !--- dark side of earth --- + anidr = 1.0_r8 + avsdr = 1.0_r8 + anidf = 1.0_r8 + avsdf = 1.0_r8 + end if + + xao_o%rAttr(index_xao_So_avsdr,n) = avsdr + xao_o%rAttr(index_xao_So_anidr,n) = anidr + xao_o%rAttr(index_xao_So_avsdf,n) = avsdf + xao_o%rAttr(index_xao_So_anidf,n) = anidf + + end do ! nloc_o + update_alb = .true. + endif ! nextsw_cday + end if ! flux_albav + + !--- update current ifrad/ofrad values if albedo was updated + + if (update_alb) then + kx = mct_aVect_indexRA(fractions_o,"ifrac") + kr = mct_aVect_indexRA(fractions_o,"ifrad") + fractions_o%rAttr(kr,:) = fractions_o%rAttr(kx,:) + kx = mct_aVect_indexRA(fractions_o,"ofrac") + kr = mct_aVect_indexRA(fractions_o,"ofrad") + fractions_o%rAttr(kr,:) = fractions_o%rAttr(kx,:) + endif + + end subroutine seq_flux_ocnalb_mct + +!=============================================================================== + + subroutine seq_flux_atmocnexch_mct( infodata, atm, ocn, fractions_a, fractions_o, & + xao_a, xao_o) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_infodata_type) , intent(in) :: infodata + type(component_type) , intent(in) :: atm + type(component_type) , intent(in) :: ocn + type(mct_aVect) , intent(in) :: fractions_a + type(mct_aVect) , intent(in) :: fractions_o + type(mct_aVect) , intent(inout) :: xao_a + type(mct_aVect) , intent(inout) :: xao_o + ! + ! Local variables + ! + type(mct_aVect) , pointer :: a2x + type(mct_aVect) , pointer :: o2x + type(mct_gsmap) , pointer :: gsmap_a + type(mct_gsmap) , pointer :: gsmap_o + + type(mct_aVect) :: a2x_e + type(mct_aVect) :: o2x_e + type(mct_aVect) :: xaop_ae + type(mct_aVect) :: xaop_oe + type(mct_aVect) :: xaop_a + type(mct_aVect) :: xaop_o + type(mct_aVect) :: fractions_oe + + integer(in) :: kw,ka,ko,iw,ia,io,kf + integer(in) :: n,i ! indices + logical :: dead_comps ! .true. => dead components are used + integer(in) :: index_tref + integer(in) :: index_qref + integer(in) :: index_duu10n + integer(in) :: index_ustar + integer(in) :: index_ssq + integer(in) :: index_re + integer(in) :: index_u10 + integer(in) :: index_taux + integer(in) :: index_tauy + integer(in) :: index_lat + integer(in) :: index_sen + integer(in) :: index_evap + integer(in) :: index_evap_16O + integer(in) :: index_evap_HDO + integer(in) :: index_evap_18O + integer(in) :: index_lwup + integer(in) :: index_sumwt + integer(in) :: atm_nx,atm_ny,ocn_nx,ocn_ny + real(r8) :: wt + real(r8) :: gust_fac = huge(1.0_r8) !wind gust factor + integer(in) :: tod, dt + logical,save:: first_call = .true. + logical :: read_restart ! .true. => model starting from restart + logical :: ocn_prognostic ! .true. => ocn is prognostic + logical :: flux_diurnal ! .true. => turn on diurnal cycle in atm/ocn fluxes + logical :: cold_start ! .true. to initialize internal fields in shr_flux diurnal + character(len=256) :: fldlist ! subset of xao fields + ! + character(*),parameter :: subName = '(seq_flux_atmocnexch_mct) ' + ! + !----------------------------------------------------------------------- + + gsmap_a => component_get_gsmap_cx(atm) + gsmap_o => component_get_gsmap_cx(ocn) + a2x => component_get_c2x_cx(atm) ! a2x_ax + o2x => component_get_c2x_cx(ocn) ! o2x_ox + + if (trim(fluxsetting) /= trim(fluxsetting_exchange)) then + call shr_sys_abort(trim(subname)//' ERROR wrong fluxsetting') + endif + + ! Update ocean surface fluxes + ! Must fabricate "reasonable" data (using dead components) + + call seq_infodata_GetData(infodata, & + read_restart=read_restart, & + dead_comps=dead_comps, & + atm_nx=atm_nx, atm_ny=atm_ny, & + ocn_nx=ocn_nx, ocn_ny=ocn_ny, & + ocn_prognostic=ocn_prognostic, & + flux_diurnal=flux_diurnal, & + gust_fac = gust_fac ) + + cold_start = .false. ! use restart data or data from last timestep + + if (first_call) then + if (.not.read_restart) cold_start = .true. + first_call = .false. + endif + + if (dead_comps) then + do n = 1,nloc_a2o + tocn(n) = 290.0_r8 ! ocn temperature ~ Kelvin + uocn(n) = 0.0_r8 ! ocn velocity, zonal ~ m/s + vocn(n) = 0.0_r8 ! ocn velocity, meridional ~ m/s + zbot(n) = 55.0_r8 ! atm height of bottom layer ~ m + ubot(n) = 0.0_r8 ! atm velocity, zonal ~ m/s + vbot(n) = 2.0_r8 ! atm velocity, meridional ~ m/s + thbot(n)= 301.0_r8 ! atm potential temperature ~ Kelvin + shum(n) = 1.e-2_r8 ! atm specific humidity ~ kg/kg + shum_16O(n) = 1.e-2_r8 ! H216O specific humidity ~ kg/kg + shum_HDO(n) = 1.e-2_r8 ! HD16O specificy humidity ~ kg/kg + shum_18O(n) = 1.e-2_r8 ! H218O specific humidity ~ kg/kg + roce_16O(n) = 1.0_r8 ! H216O ratio ~ mol/mol + roce_HDO(n) = 1.0_r8 ! HD16O ratio ~ mol/mol + roce_18O(n) = 1.0_r8 ! H218O ratio ~ mol/mol + dens(n) = 1.0_r8 ! atm density ~ kg/m^3 + tbot(n) = 300.0_r8 ! atm temperature ~ Kelvin + enddo + else + + !--- instantiate exchange grid aVects + call mct_AVect_init(a2x_e, a2x, nloc_ae) + call mct_AVect_zero(a2x_e) + call mct_AVect_init(o2x_e, o2x, nloc_oe) + call mct_AVect_zero(o2x_e) + + !--- rearrange a2x and o2x into exchange grid + + call mct_rearr_rearrange(a2x, a2x_e, Re_a2e, VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + call mct_rearr_rearrange(o2x, o2x_e, Re_o2e, VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + + !--- extract fields from a2x and o2x (_e) into local arrays on exchange grid + + ko = mct_sMat_indexIA(sMata2o,'lrow') ! local row index + ka = mct_sMat_indexIA(sMata2o,'lcol') ! local column index + + do n = 1,nloc_a2o + io = sMata2o%data%iAttr(ko,n) + ia = sMata2o%data%iAttr(ka,n) + zbot(n) = a2x_e%rAttr(index_a2x_Sa_z ,ia) + ubot(n) = a2x_e%rAttr(index_a2x_Sa_u ,ia) + vbot(n) = a2x_e%rAttr(index_a2x_Sa_v ,ia) + thbot(n)= a2x_e%rAttr(index_a2x_Sa_ptem,ia) + shum(n) = a2x_e%rAttr(index_a2x_Sa_shum,ia) + shum_16O(n) = a2x_e%rAttr(index_a2x_Sa_shum_16O,ia) + shum_HDO(n) = a2x_e%rAttr(index_a2x_Sa_shum_HDO,ia) + shum_18O(n) = a2x_e%rAttr(index_a2x_Sa_shum_18O,ia) + dens(n) = a2x_e%rAttr(index_a2x_Sa_dens,ia) + tbot(n) = a2x_e%rAttr(index_a2x_Sa_tbot,ia) + tocn(n) = o2x_e%rAttr(index_o2x_So_t ,io) + uocn(n) = o2x_e%rAttr(index_o2x_So_u ,io) + vocn(n) = o2x_e%rAttr(index_o2x_So_v ,io) + roce_16O(n) = o2x_e%rAttr(index_o2x_So_roce_16O, io) + roce_HDO(n) = o2x_e%rAttr(index_o2x_So_roce_HDO, io) + roce_18O(n) = o2x_e%rAttr(index_o2x_So_roce_18O, io) + enddo + call mct_aVect_clean(a2x_e) + call mct_aVect_clean(o2x_e) + end if + + if (flux_diurnal) then + call shr_flux_atmocn_diurnal (nloc_a2o , zbot , ubot, vbot, thbot, & + shum , shum_16O , shum_HDO, shum_18O, dens , tbot, uocn, vocn , & + tocn , emask, sen , lat , lwup , & + roce_16O, roce_HDO, roce_18O, & + evap , evap_16O, evap_HDO, evap_18O, taux , tauy, tref, qref , & + uGust, lwdn , swdn , swup, prec, & + fswpen, ocnsal, ocn_prognostic, flux_diurnal, & + lats , lons , warm , salt , speed, regime, & + warmMax, windMax, qSolAvg, windAvg, & + warmMaxInc, windMaxInc, qSolInc, windInc, nInc, & + tbulk, tskin, tskin_day, tskin_night, & + cskin, cskin_night, tod, dt, & + duu10n,ustar, re , ssq , missval = 0.0_r8, & + cold_start=cold_start) + else + call shr_flux_atmocn (nloc_a2o , zbot , ubot, vbot, thbot, prec_gust, gust_fac, & + shum , shum_16O , shum_HDO, shum_18O, dens , tbot, uocn, vocn , & + tocn , emask, sen , lat , lwup , & + roce_16O, roce_HDO, roce_18O, & + evap , evap_16O, evap_HDO, evap_18O, taux, tauy, tref, qref , & + duu10n,ustar, re , ssq , missval = 0.0_r8 ) + endif + + !--- create temporary aVects on exchange, atm, or ocn decomp as needed + + fldlist = trim(seq_flds_xao_states)//":"//trim(seq_flds_xao_fluxes)//":sumwt" + call mct_aVect_init(xaop_ae,rList=trim(fldlist),lsize=nloc_ae) + call mct_aVect_zero(xaop_ae) + call mct_aVect_init(xaop_oe,rList=trim(fldlist),lsize=nloc_oe) + call mct_aVect_zero(xaop_oe) + call mct_aVect_init(xaop_a, rList=trim(fldlist),lsize=nloc_a) + call mct_aVect_zero(xaop_a) + call mct_aVect_init(xaop_o, rList=trim(fldlist),lsize=nloc_o) + call mct_aVect_zero(xaop_o) + + index_tref = mct_aVect_indexRA(xaop_ae,"So_tref") + index_qref = mct_aVect_indexRA(xaop_ae,"So_qref") + index_duu10n = mct_aVect_indexRA(xaop_ae,"So_duu10n") + index_ustar = mct_aVect_indexRA(xaop_ae,"So_ustar") + index_ssq = mct_aVect_indexRA(xaop_ae,"So_ssq") + index_re = mct_aVect_indexRA(xaop_ae,"So_re") + index_u10 = mct_aVect_indexRA(xaop_ae,"So_u10") + index_taux = mct_aVect_indexRA(xaop_ae,"Faox_taux") + index_tauy = mct_aVect_indexRA(xaop_ae,"Faox_tauy") + index_lat = mct_aVect_indexRA(xaop_ae,"Faox_lat") + index_sen = mct_aVect_indexRA(xaop_ae,"Faox_sen") + index_evap = mct_aVect_indexRA(xaop_ae,"Faox_evap") + index_evap_16O = mct_aVect_indexRA(xaop_ae,"Faox_evap_16O", perrWith='quiet') + index_evap_HDO = mct_aVect_indexRA(xaop_ae,"Faox_evap_HDO", perrWith='quiet') + index_evap_18O = mct_aVect_indexRA(xaop_ae,"Faox_evap_18O", perrWith='quiet') + index_lwup = mct_aVect_indexRA(xaop_ae,"Faox_lwup") + index_sumwt = mct_aVect_indexRA(xaop_ae,"sumwt") + + !--- aggregate ocean values locally based on exchange grid decomp + + ko = mct_sMat_indexIA(sMata2o,'lrow') ! local row index + ka = mct_sMat_indexIA(sMata2o,'lcol') ! local column index + kw = mct_sMat_indexRA(sMata2o,'weight') ! weight index + + do n = 1,nloc_a2o + io = sMata2o%data%iAttr(ko,n) + ia = sMata2o%data%iAttr(ka,n) + wt = sMata2o%data%rAttr(kw,n) + xaop_oe%rAttr(index_sen ,io) = xaop_oe%rAttr(index_sen ,io) + sen(n) * wt + xaop_oe%rAttr(index_lat ,io) = xaop_oe%rAttr(index_lat ,io) + lat(n) * wt + xaop_oe%rAttr(index_taux ,io) = xaop_oe%rAttr(index_taux ,io) + taux(n)* wt + xaop_oe%rAttr(index_tauy ,io) = xaop_oe%rAttr(index_tauy ,io) + tauy(n)* wt + xaop_oe%rAttr(index_evap ,io) = xaop_oe%rAttr(index_evap ,io) + evap(n)* wt + if ( index_evap_16O /= 0 ) xaop_oe%rAttr(index_evap_16O ,io) = xaop_oe%rAttr(index_evap_16O ,io) + evap_16O(n)* wt + if ( index_evap_HDO /= 0 ) xaop_oe%rAttr(index_evap_HDO ,io) = xaop_oe%rAttr(index_evap_HDO ,io) + evap_HDO(n)* wt + if ( index_evap_18O /= 0 ) xaop_oe%rAttr(index_evap_18O ,io) = xaop_oe%rAttr(index_evap_18O ,io) + evap_18O(n)* wt + xaop_oe%rAttr(index_tref ,io) = xaop_oe%rAttr(index_tref ,io) + tref(n)* wt + xaop_oe%rAttr(index_qref ,io) = xaop_oe%rAttr(index_qref ,io) + qref(n)* wt + xaop_oe%rAttr(index_ustar ,io) = xaop_oe%rAttr(index_ustar ,io) + ustar(n)*wt ! friction velocity + xaop_oe%rAttr(index_re ,io) = xaop_oe%rAttr(index_re ,io) + re(n) * wt ! reynolds number + xaop_oe%rAttr(index_ssq ,io) = xaop_oe%rAttr(index_ssq ,io) + ssq(n) * wt ! s.hum. saturation at Ts + xaop_oe%rAttr(index_lwup ,io) = xaop_oe%rAttr(index_lwup ,io) + lwup(n)* wt + xaop_oe%rAttr(index_duu10n,io) = xaop_oe%rAttr(index_duu10n,io) + duu10n(n)*wt + xaop_oe%rAttr(index_u10 ,io) = xaop_oe%rAttr(index_u10 ,io) + sqrt(duu10n(n))*wt + xaop_oe%rAttr(index_sumwt ,io) = xaop_oe%rAttr(index_sumwt ,io) + wt + enddo + + !--- aggregate atm values locally based on exchange grid decomp + + ko = mct_sMat_indexIA(sMato2a,'lcol') ! local column index + ka = mct_sMat_indexIA(sMato2a,'lrow') ! local row index + kw = mct_sMat_indexRA(sMato2a,'weight') ! weight index + kf = mct_aVect_indexRA(fractions_o,"ofrac") + + !--- to apply fraction corrections, the indexing must be correct so rearrange + call mct_avect_init(fractions_oe,fractions_o,lsize=nloc_oe) + call mct_rearr_rearrange(fractions_o, fractions_oe, Re_o2e, VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + do n = 1,nloc_o2a + io = sMato2a%data%iAttr(ko,n) + ia = sMato2a%data%iAttr(ka,n) +!tcx wt = sMato2a%data%rAttr(kw,n) + wt = sMato2a%data%rAttr(kw,n) * fractions_oe%rAttr(kf,io) + xaop_ae%rAttr(index_sen ,ia) = xaop_ae%rAttr(index_sen ,ia) + sen(n) * wt + xaop_ae%rAttr(index_lat ,ia) = xaop_ae%rAttr(index_lat ,ia) + lat(n) * wt + xaop_ae%rAttr(index_taux ,ia) = xaop_ae%rAttr(index_taux ,ia) + taux(n)* wt + xaop_ae%rAttr(index_tauy ,ia) = xaop_ae%rAttr(index_tauy ,ia) + tauy(n)* wt + xaop_ae%rAttr(index_evap ,ia) = xaop_ae%rAttr(index_evap ,ia) + evap(n)* wt + if ( index_evap_16O /= 0 ) xaop_ae%rAttr(index_evap_16O ,ia) = xaop_ae%rAttr(index_evap_16O ,ia) + evap_16O(n)* wt + if ( index_evap_HDO /= 0 ) xaop_ae%rAttr(index_evap_HDO ,ia) = xaop_ae%rAttr(index_evap_HDO ,ia) + evap_HDO(n)* wt + if ( index_evap_18O /= 0 ) xaop_ae%rAttr(index_evap_18O ,ia) = xaop_ae%rAttr(index_evap_18O ,ia) + evap_18O(n)* wt + xaop_ae%rAttr(index_tref ,ia) = xaop_ae%rAttr(index_tref ,ia) + tref(n)* wt + xaop_ae%rAttr(index_qref ,ia) = xaop_ae%rAttr(index_qref ,ia) + qref(n)* wt + xaop_ae%rAttr(index_ustar ,ia) = xaop_ae%rAttr(index_ustar ,ia) + ustar(n)*wt ! friction velocity + xaop_ae%rAttr(index_re ,ia) = xaop_ae%rAttr(index_re ,ia) + re(n) * wt ! reynolds number + xaop_ae%rAttr(index_ssq ,ia) = xaop_ae%rAttr(index_ssq ,ia) + ssq(n) * wt ! s.hum. saturation at Ts + xaop_ae%rAttr(index_lwup ,ia) = xaop_ae%rAttr(index_lwup ,ia) + lwup(n)* wt + xaop_ae%rAttr(index_duu10n,ia) = xaop_ae%rAttr(index_duu10n,ia) + duu10n(n)*wt + xaop_ae%rAttr(index_u10 ,ia) = xaop_ae%rAttr(index_u10 ,ia) + sqrt(duu10n(n))*wt + xaop_ae%rAttr(index_sumwt ,ia) = xaop_ae%rAttr(index_sumwt ,ia) + wt + enddo + + call mct_aVect_clean(fractions_oe) + + !--- rearrange and sum from exchange grid to gsmap_a and gsmap_o decomps + + call mct_rearr_rearrange(xaop_ae, xaop_a, Re_e2a, sum=.true., & + VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + call mct_rearr_rearrange(xaop_oe, xaop_o, Re_e2o, sum=.true., & + VECTOR=mct_usevector, ALLTOALL=mct_usealltoall) + + !--- normalize by sum of wts associated with mapping + + do n = 1,nloc_a + wt = xaop_a%rAttr(index_sumwt,n) + if (wt /= 0.0_r8) then + wt = 1.0_r8/wt + else + wt = 1.0_r8 + endif + xaop_a%rAttr(:,n) = xaop_a%rAttr(:,n) * wt + enddo + + do n = 1,nloc_o + wt = xaop_o%rAttr(index_sumwt,n) + if (wt /= 0.0_r8) then + wt = 1.0_r8/wt + else + wt = 1.0_r8 + endif + xaop_o%rAttr(:,n) = xaop_o%rAttr(:,n) * wt + enddo + + !--- copy subset of fields to xao_a and xao_o and clean up + + call mct_avect_clean(xaop_ae) + call mct_avect_clean(xaop_oe) + + call mct_avect_copy(xaop_a, xao_a) + call mct_avect_copy(xaop_o, xao_o) + + call mct_avect_clean(xaop_a) + call mct_avect_clean(xaop_o) + + end subroutine seq_flux_atmocnexch_mct + +!=============================================================================== + + subroutine seq_flux_atmocn_mct(infodata, tod, dt, a2x, o2x, xao) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_infodata_type) , intent(in) :: infodata + integer(in) , intent(in) :: tod,dt ! NEW + type(mct_aVect) , intent(in) :: a2x ! a2x_ax or a2x_ox + type(mct_aVect) , intent(in) :: o2x ! o2x_ax or o2x_ox + type(mct_aVect) , intent(inout) :: xao + ! + ! Local variables + ! + logical :: flux_albav ! flux avg option + logical :: dead_comps ! .true. => dead components are used + integer(in) :: n,i ! indices + real(r8) :: rlat ! gridcell latitude in radians + real(r8) :: rlon ! gridcell longitude in radians + real(r8) :: cosz ! Cosine of solar zenith angle + real(r8) :: eccen ! Earth orbit eccentricity + real(r8) :: mvelpp ! Earth orbit + real(r8) :: lambm0 ! Earth orbit + real(r8) :: obliqr ! Earth orbit + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: calday ! calendar day including fraction, at 0e + real(r8) :: nextsw_cday ! calendar day of next atm shortwave + real(r8) :: anidr ! albedo: near infrared, direct + real(r8) :: avsdr ! albedo: visible , direct + real(r8) :: anidf ! albedo: near infrared, diffuse + real(r8) :: avsdf ! albedo: visible , diffuse + real(r8) :: gust_fac = huge(1.0_r8) !wind gust factor + integer(in) :: nloc, nloca, nloco ! number of gridcells + integer(in) :: ID ! comm ID + logical,save:: first_call = .true. + logical :: cold_start ! .true. to initialize internal fields in shr_flux diurnal + logical :: read_restart ! .true. => continue run + logical :: ocn_prognostic ! .true. => ocn is prognostic + logical :: flux_diurnal ! .true. => turn on diurnal cycle in atm/ocn fluxes + ! + real(r8),parameter :: albdif = 0.06_r8 ! 60 deg reference albedo, diffuse + real(r8),parameter :: albdir = 0.07_r8 ! 60 deg reference albedo, direct + character(*),parameter :: subName = '(seq_flux_atmocn_mct) ' + ! + !----------------------------------------------------------------------- + + call seq_infodata_getData(infodata , & + read_restart=read_restart, & + flux_albav=flux_albav, & + dead_comps=dead_comps, & + ocn_prognostic=ocn_prognostic, & + flux_diurnal=flux_diurnal, & + gust_fac = gust_fac ) + + cold_start = .false. ! use restart data or data from last timestep + + if (first_call) then + if (.not.read_restart) cold_start = .true. + index_xao_So_tref = mct_aVect_indexRA(xao,'So_tref') + index_xao_So_qref = mct_aVect_indexRA(xao,'So_qref') + index_xao_So_ustar = mct_aVect_indexRA(xao,'So_ustar') + index_xao_So_re = mct_aVect_indexRA(xao,'So_re') + index_xao_So_ssq = mct_aVect_indexRA(xao,'So_ssq') + index_xao_So_u10 = mct_aVect_indexRA(xao,'So_u10') + index_xao_So_duu10n = mct_aVect_indexRA(xao,'So_duu10n') + index_xao_Faox_taux = mct_aVect_indexRA(xao,'Faox_taux') + index_xao_Faox_tauy = mct_aVect_indexRA(xao,'Faox_tauy') + index_xao_Faox_lat = mct_aVect_indexRA(xao,'Faox_lat') + index_xao_Faox_sen = mct_aVect_indexRA(xao,'Faox_sen') + index_xao_Faox_evap = mct_aVect_indexRA(xao,'Faox_evap') + index_xao_Faox_evap_16O = mct_aVect_indexRA(xao,'Faox_evap_16O', perrWith='quiet') + index_xao_Faox_evap_HDO = mct_aVect_indexRA(xao,'Faox_evap_HDO', perrWith='quiet') + index_xao_Faox_evap_18O = mct_aVect_indexRA(xao,'Faox_evap_18O', perrWith='quiet') + index_xao_Faox_lwup = mct_aVect_indexRA(xao,'Faox_lwup') + index_xao_Faox_swdn = mct_aVect_indexRA(xao,'Faox_swdn') + index_xao_Faox_swup = mct_aVect_indexRA(xao,'Faox_swup') + index_xao_So_fswpen = mct_aVect_indexRA(xao,'So_fswpen') + index_xao_So_warm_diurn = mct_aVect_indexRA(xao,'So_warm_diurn') + index_xao_So_salt_diurn = mct_aVect_indexRA(xao,'So_salt_diurn') + index_xao_So_speed_diurn = mct_aVect_indexRA(xao,'So_speed_diurn') + index_xao_So_regime_diurn = mct_aVect_indexRA(xao,'So_regime_diurn') + index_xao_So_tskin_diurn = mct_aVect_indexRA(xao,'So_tskin_diurn') + index_xao_So_tskin_day_diurn = mct_aVect_indexRA(xao,'So_tskin_day_diurn') + index_xao_So_tskin_night_diurn = mct_aVect_indexRA(xao,'So_tskin_night_diurn') + index_xao_So_cskin_diurn = mct_aVect_indexRA(xao,'So_cskin_diurn') + index_xao_So_cskin_night_diurn = mct_aVect_indexRA(xao,'So_cskin_night_diurn') + index_xao_So_tbulk_diurn = mct_aVect_indexRA(xao,'So_tbulk_diurn') + index_xao_So_warmmax_diurn = mct_aVect_indexRA(xao,'So_warmmax_diurn') + index_xao_So_windmax_diurn = mct_aVect_indexRA(xao,'So_windmax_diurn') + index_xao_So_qsolavg_diurn = mct_aVect_indexRA(xao,'So_qsolavg_diurn') + index_xao_So_windavg_diurn = mct_aVect_indexRA(xao,'So_windavg_diurn') + index_xao_So_warmmaxinc_diurn = mct_aVect_indexRA(xao,'So_warmmaxinc_diurn') + index_xao_So_windmaxinc_diurn = mct_aVect_indexRA(xao,'So_windmaxinc_diurn') + index_xao_So_qsolinc_diurn = mct_aVect_indexRA(xao,'So_qsolinc_diurn') + index_xao_So_windinc_diurn = mct_aVect_indexRA(xao,'So_windinc_diurn') + index_xao_So_ninc_diurn = mct_aVect_indexRA(xao,'So_ninc_diurn') + + index_a2x_Sa_z = mct_aVect_indexRA(a2x,'Sa_z') + index_a2x_Sa_u = mct_aVect_indexRA(a2x,'Sa_u') + index_a2x_Sa_v = mct_aVect_indexRA(a2x,'Sa_v') + index_a2x_Sa_tbot = mct_aVect_indexRA(a2x,'Sa_tbot') + index_a2x_Sa_ptem = mct_aVect_indexRA(a2x,'Sa_ptem') + index_a2x_Sa_shum = mct_aVect_indexRA(a2x,'Sa_shum') + index_a2x_Sa_shum_16O = mct_aVect_indexRA(a2x,'Sa_shum_16O', perrWith='quiet') + index_a2x_Sa_shum_HDO = mct_aVect_indexRA(a2x,'Sa_shum_HDO', perrWith='quiet') + index_a2x_Sa_shum_18O = mct_aVect_indexRA(a2x,'Sa_shum_18O', perrWith='quiet') + index_a2x_Sa_dens = mct_aVect_indexRA(a2x,'Sa_dens') + index_a2x_Faxa_lwdn = mct_aVect_indexRA(a2x,'Faxa_lwdn') + index_a2x_Faxa_rainc= mct_aVect_indexRA(a2x,'Faxa_rainc') + index_a2x_Faxa_rainl= mct_aVect_indexRA(a2x,'Faxa_rainl') + index_a2x_Faxa_snowc= mct_aVect_indexRA(a2x,'Faxa_snowc') + index_a2x_Faxa_snowl= mct_aVect_indexRA(a2x,'Faxa_snowl') + + index_o2x_So_t = mct_aVect_indexRA(o2x,'So_t') + index_o2x_So_u = mct_aVect_indexRA(o2x,'So_u') + index_o2x_So_v = mct_aVect_indexRA(o2x,'So_v') + index_o2x_So_fswpen = mct_aVect_indexRA(o2x,'So_fswpen') + index_o2x_So_s = mct_aVect_indexRA(o2x,'So_s') + index_o2x_So_roce_16O = mct_aVect_indexRA(o2x,'So_roce_16O', perrWith='quiet') + index_o2x_So_roce_HDO = mct_aVect_indexRA(o2x,'So_roce_HDO', perrWith='quiet') + index_o2x_So_roce_18O = mct_aVect_indexRA(o2x,'So_roce_18O', perrWith='quiet') + first_call = .false. + end if + + if (trim(fluxsetting) /= trim(fluxsetting_atmocn)) then + call shr_sys_abort(trim(subname)//' ERROR wrong fluxsetting') + endif + + nloc = mct_aVect_lsize(xao) + nloca = mct_aVect_lsize(a2x) + nloco = mct_aVect_lsize(o2x) + + if (nloc /= nloca .or. nloc /= nloco) then + call shr_sys_abort(trim(subname)//' ERROR nloc sizes do not match') + endif + + ! Update ocean surface fluxes + ! Must fabricate "reasonable" data (when using dead components) + + emask = mask + if (dead_comps) then + do n = 1,nloc + mask(n) = 1 ! ocn domain mask ~ 0 <=> inactive cell + tocn(n) = 290.0_r8 ! ocn temperature ~ Kelvin + uocn(n) = 0.0_r8 ! ocn velocity, zonal ~ m/s + vocn(n) = 0.0_r8 ! ocn velocity, meridional ~ m/s + zbot(n) = 55.0_r8 ! atm height of bottom layer ~ m + ubot(n) = 0.0_r8 ! atm velocity, zonal ~ m/s + vbot(n) = 2.0_r8 ! atm velocity, meridional ~ m/s + thbot(n)= 301.0_r8 ! atm potential temperature ~ Kelvin + shum(n) = 1.e-2_r8 ! atm specific humidity ~ kg/kg +!wiso note: shum_* should be multiplied by Rstd_* here? + shum_16O(n) = 1.e-2_r8 ! H216O specific humidity ~ kg/kg + shum_HDO(n) = 1.e-2_r8 ! HD16O specific humidity ~ kg/kg + shum_18O(n) = 1.e-2_r8 ! H218O specific humidity ~ kg/kg + roce_16O(n) = 1.0_r8 ! H216O surface ratio ~ mol/mol + roce_HDO(n) = 1.0_r8 ! HDO surface ratio ~ mol/mol + roce_18O(n) = 1.0_r8 ! H218O surface ratio ~ mol/mol + dens(n) = 1.0_r8 ! atm density ~ kg/m^3 + tbot(n) = 300.0_r8 ! atm temperature ~ Kelvin + uGust(n)= 0.0_r8 + lwdn(n) = 0.0_r8 + prec(n) = 0.0_r8 + prec_gust(n) = 0.0_r8 + fswpen(n)= 0.0_r8 + ocnsal(n)= 0.0_r8 + + warm (n) = 0.0_r8 + salt (n) = 0.0_r8 + speed (n) = 0.0_r8 + regime (n) = 0.0_r8 + warmMax (n) = 0.0_r8 + windMax (n) = 0.0_r8 + qSolAvg (n) = 0.0_r8 + windAvg (n) = 0.0_r8 + warmMaxInc (n) = 0.0_r8 + windMaxInc (n) = 0.0_r8 + qSolInc (n) = 0.0_r8 + windInc (n) = 0.0_r8 + nInc (n) = 0.0_r8 + tbulk (n) = 0.0_r8 + tskin (n) = 0.0_r8 + tskin_day (n) = 0.0_r8 + tskin_night(n) = 0.0_r8 + cskin (n) = 0.0_r8 + cskin_night(n) = 0.0_r8 + swdn (n) = 0.0_r8 + swup (n) = 0.0_r8 + enddo + else + do n = 1,nloc + nInc(n) = 0._r8 ! needed for minval/maxval calculation + if (mask(n) /= 0) then + zbot(n) = a2x%rAttr(index_a2x_Sa_z ,n) + ubot(n) = a2x%rAttr(index_a2x_Sa_u ,n) + vbot(n) = a2x%rAttr(index_a2x_Sa_v ,n) + thbot(n)= a2x%rAttr(index_a2x_Sa_ptem,n) + shum(n) = a2x%rAttr(index_a2x_Sa_shum,n) + if ( index_a2x_Sa_shum_16O /= 0 ) shum_16O(n) = a2x%rAttr(index_a2x_Sa_shum_16O,n) + if ( index_a2x_Sa_shum_HDO /= 0 ) shum_HDO(n) = a2x%rAttr(index_a2x_Sa_shum_HDO,n) + if ( index_a2x_Sa_shum_18O /= 0 ) shum_18O(n) = a2x%rAttr(index_a2x_Sa_shum_18O,n) + dens(n) = a2x%rAttr(index_a2x_Sa_dens,n) + tbot(n) = a2x%rAttr(index_a2x_Sa_tbot,n) + tocn(n) = o2x%rAttr(index_o2x_So_t ,n) + uocn(n) = o2x%rAttr(index_o2x_So_u ,n) + vocn(n) = o2x%rAttr(index_o2x_So_v ,n) + if ( index_o2x_So_roce_16O /= 0 ) roce_16O(n) = o2x%rAttr(index_o2x_So_roce_16O, n) + if ( index_o2x_So_roce_HDO /= 0 ) roce_HDO(n) = o2x%rAttr(index_o2x_So_roce_HDO, n) + if ( index_o2x_So_roce_18O /= 0 ) roce_18O(n) = o2x%rAttr(index_o2x_So_roce_18O, n) + !--- mask missing atm or ocn data if found + if (dens(n) < 1.0e-12 .or. tocn(n) < 1.0) then + emask(n) = 0 + !write(logunit,*) 'aoflux tcx1',n,dens(n),tocn(n) + endif +! !!uGust(n) = 1.5_r8*sqrt(uocn(n)**2 + vocn(n)**2) ! there is no wind gust data from ocn + uGust(n) = 0.0_r8 + lwdn (n) = a2x%rAttr(index_a2x_Faxa_lwdn ,n) + prec (n) = a2x%rAttr(index_a2x_Faxa_rainc,n) & + & + a2x%rAttr(index_a2x_Faxa_rainl,n) & + & + a2x%rAttr(index_a2x_Faxa_snowc,n) & + & + a2x%rAttr(index_a2x_Faxa_snowl,n) + prec_gust (n) = a2x%rAttr(index_a2x_Faxa_rainc,n) + fswpen(n)= o2x%rAttr(index_o2x_So_fswpen ,n) + ocnsal(n)= o2x%rAttr(index_o2x_So_s ,n) + + warm (n) = xao%rAttr(index_xao_So_warm_diurn ,n) + salt (n) = xao%rAttr(index_xao_So_salt_diurn ,n) + speed (n) = xao%rAttr(index_xao_So_speed_diurn ,n) + regime (n) = xao%rAttr(index_xao_So_regime_diurn ,n) + warmMax (n) = xao%rAttr(index_xao_So_warmMax_diurn ,n) + windMax (n) = xao%rAttr(index_xao_So_windMax_diurn ,n) + qSolAvg (n) = xao%rAttr(index_xao_So_qsolavg_diurn ,n) + windAvg (n) = xao%rAttr(index_xao_So_windavg_diurn ,n) + warmMaxInc (n) = xao%rAttr(index_xao_So_warmMaxInc_diurn,n) + windMaxInc (n) = xao%rAttr(index_xao_So_windMaxInc_diurn,n) + qSolInc (n) = xao%rAttr(index_xao_So_qSolInc_diurn ,n) + windInc (n) = xao%rAttr(index_xao_So_windInc_diurn ,n) + nInc (n) = xao%rAttr(index_xao_So_nInc_diurn ,n) + tbulk (n) = xao%rAttr(index_xao_So_tbulk_diurn ,n) + tskin (n) = xao%rAttr(index_xao_So_tskin_diurn ,n) + tskin_day (n) = xao%rAttr(index_xao_So_tskin_day_diurn ,n) + tskin_night(n) = xao%rAttr(index_xao_So_tskin_night_diurn,n) + cskin (n) = xao%rAttr(index_xao_So_cskin_diurn ,n) + cskin_night(n) = xao%rAttr(index_xao_So_cskin_night_diurn,n) + ! set in flux_ocnalb using data from previous timestep + swdn (n) = xao%rAttr(index_xao_Faox_swdn ,n) + swup (n) = xao%rAttr(index_xao_Faox_swup ,n) + end if + enddo + end if + + if (flux_diurnal) then + call shr_flux_atmocn_diurnal (nloc , zbot , ubot, vbot, thbot, & + shum , shum_16O , shum_HDO, shum_18O, dens , tbot, uocn, vocn , & + tocn , emask, sen , lat , lwup , & + roce_16O, roce_HDO, roce_18O, & + evap , evap_16O, evap_HDO, evap_18O, taux , tauy, tref, qref , & + uGust, lwdn , swdn , swup, prec, & + fswpen, ocnsal, ocn_prognostic, flux_diurnal, & + lats, lons , warm , salt , speed, regime, & + warmMax, windMax, qSolAvg, windAvg, & + warmMaxInc, windMaxInc, qSolInc, windInc, nInc, & + tbulk, tskin, tskin_day, tskin_night, & + cskin, cskin_night, tod, dt, & + duu10n,ustar, re , ssq, & + !missval should not be needed if flux calc + !consistent with mrgx2a fraction + !duu10n,ustar, re , ssq, missval = 0.0_r8 ) + cold_start=cold_start) + else + call shr_flux_atmocn (nloc , zbot , ubot, vbot, thbot, prec_gust, gust_fac, & + shum , shum_16O , shum_HDO, shum_18O, dens , tbot, uocn, vocn , & + tocn , emask, sen , lat , lwup , & + roce_16O, roce_HDO, roce_18O, & + evap , evap_16O, evap_HDO, evap_18O, taux , tauy, tref, qref , & + duu10n,ustar, re , ssq) + !missval should not be needed if flux calc + !consistent with mrgx2a fraction + !duu10n,ustar, re , ssq, missval = 0.0_r8 ) + endif + + do n = 1,nloc + if (mask(n) /= 0) then + xao%rAttr(index_xao_Faox_sen ,n) = sen(n) + xao%rAttr(index_xao_Faox_lat ,n) = lat(n) + xao%rAttr(index_xao_Faox_taux,n) = taux(n) + xao%rAttr(index_xao_Faox_tauy,n) = tauy(n) + xao%rAttr(index_xao_Faox_evap,n) = evap(n) + if ( index_xao_Faox_evap_16O /= 0 ) xao%rAttr(index_xao_Faox_evap_16O,n) = evap_16O(n) + if ( index_xao_Faox_evap_HDO /= 0 ) xao%rAttr(index_xao_Faox_evap_HDO,n) = evap_HDO(n) + if ( index_xao_Faox_evap_18O /= 0 ) xao%rAttr(index_xao_Faox_evap_18O,n) = evap_18O(n) + xao%rAttr(index_xao_So_tref ,n) = tref(n) + xao%rAttr(index_xao_So_qref ,n) = qref(n) + xao%rAttr(index_xao_So_ustar ,n) = ustar(n) ! friction velocity + xao%rAttr(index_xao_So_re ,n) = re(n) ! reynolds number + xao%rAttr(index_xao_So_ssq ,n) = ssq(n) ! s.hum. saturation at Ts + xao%rAttr(index_xao_Faox_lwup,n) = lwup(n) + xao%rAttr(index_xao_So_duu10n,n) = duu10n(n) + xao%rAttr(index_xao_So_u10 ,n) = sqrt(duu10n(n)) + xao%rAttr(index_xao_So_warm_diurn ,n) = warm(n) + xao%rAttr(index_xao_So_salt_diurn ,n) = salt(n) + xao%rAttr(index_xao_So_speed_diurn ,n) = speed(n) + xao%rAttr(index_xao_So_regime_diurn ,n) = regime(n) + xao%rAttr(index_xao_So_warmMax_diurn ,n) = warmMax(n) + xao%rAttr(index_xao_So_windMax_diurn ,n) = windMax(n) + xao%rAttr(index_xao_So_qSolAvg_diurn ,n) = qSolAvg(n) + xao%rAttr(index_xao_So_windAvg_diurn ,n) = windAvg(n) + xao%rAttr(index_xao_So_warmMaxInc_diurn ,n) = warmMaxInc(n) + xao%rAttr(index_xao_So_windMaxInc_diurn ,n) = windMaxInc(n) + xao%rAttr(index_xao_So_qSolInc_diurn ,n) = qSolInc(n) + xao%rAttr(index_xao_So_windInc_diurn ,n) = windInc(n) + xao%rAttr(index_xao_So_nInc_diurn ,n) = nInc(n) + xao%rAttr(index_xao_So_tbulk_diurn ,n) = tbulk(n) + xao%rAttr(index_xao_So_tskin_diurn ,n) = tskin(n) + xao%rAttr(index_xao_So_tskin_day_diurn ,n) = tskin_day(n) + xao%rAttr(index_xao_So_tskin_night_diurn,n) = tskin_night(n) + xao%rAttr(index_xao_So_cskin_diurn ,n) = cskin(n) + xao%rAttr(index_xao_So_cskin_night_diurn,n) = cskin_night(n) + xao%rAttr(index_xao_So_fswpen ,n) = fswpen(n) + end if + enddo + + end subroutine seq_flux_atmocn_mct + +!=============================================================================== + +end module seq_flux_mct diff --git a/driver-mct/main/seq_frac_mct.F90 b/driver-mct/main/seq_frac_mct.F90 new file mode 100644 index 000000000000..f097e60f993a --- /dev/null +++ b/driver-mct/main/seq_frac_mct.F90 @@ -0,0 +1,810 @@ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_frac_mct -- handles surface fractions. +! +! Fraction Notes: tcraig, august 2008 +! Assumes is running on CPLID pes +! +! the fractions fields are now afrac, ifrac, ofrac, lfrac, and lfrin. +! afrac = fraction of atm on a grid +! lfrac = fraction of lnd on a grid +! ifrac = fraction of ice on a grid +! ofrac = fraction of ocn on a grid +! lfrin = land fraction defined by the land model +! ifrad = fraction of ocn on a grid at last radiation time +! ofrad = fraction of ice on a grid at last radiation time +! afrac, lfrac, ifrac, and ofrac are the self-consistent values in the +! system. lfrin is the fraction on the land grid and is allowed to +! vary from the self-consistent value as descibed below. ifrad +! and ofrad are needed for the swnet calculation. +! the fractions fields are defined for each grid in the fraction bundles as +! needed as follows. +! character(*),parameter :: fraclist_a = 'afrac:ifrac:ofrac:lfrac:lfrin' +! character(*),parameter :: fraclist_o = 'afrac:ifrac:ofrac:ifrad:ofrad' +! character(*),parameter :: fraclist_i = 'afrac:ifrac:ofrac' +! character(*),parameter :: fraclist_l = 'afrac:lfrac:lfrin' +! character(*),parameter :: fraclist_g = 'gfrac:lfrac' +! character(*),parameter :: fraclist_r = 'lfrac:rfrac' +! +! we assume ocean and ice are on the same grids, same masks +! we assume ocn2atm and ice2atm are masked maps +! we assume lnd2atm is a global map +! we assume that the ice fraction evolves in time but that +! the land model fraction does not. the ocean fraction then +! is just the complement of the ice fraction over the region +! of the ocean/ice mask. +! we assume that component domains are filled with the total +! potential mask/fraction on that grid, but that the fractions +! sent at run time are always the relative fraction covered. +! for example, if an ice cell can be up to 50% covered in +! ice and 50% land, then the ice domain should have a fraction +! value of 0.5 at that grid cell. at run time though, the ice +! fraction will be between 0.0 and 1.0 meaning that grid cells +! is covered with between 0.0 and 0.5 by ice. the "relative" fractions +! sent at run-time are corrected by the model to be total fractions +! such that +! in general, on every grid, +! fractions_*(afrac) = 1.0 +! fractions_*(ifrac) + fractions_*(ofrac) + fractions_*(lfrac) = 1.0 +! where fractions_* are a bundle of fractions on a particular grid and +! *frac (ie afrac) is the fraction of a particular component in the bundle. +! +! fraclist_g and fraclist_r don't yet interact with atm, lnd, ice, ocn. +! +! the fractions are computed fundamentally as follows (although the +! detailed implementation might be slightly different) +! initialization (frac_init): +! afrac is set on all grids +! fractions_a(afrac) = 1.0 +! fractions_o(afrac) = mapa2o(fractions_a(afrac)) +! fractions_i(afrac) = mapa2i(fractions_a(afrac)) +! fractions_l(afrac) = mapa2l(fractions_a(afrac)) +! initially assume ifrac on all grids is zero +! fractions_*(ifrac) = 0.0 +! fractions/masks provided by surface components +! fractions_o(ofrac) = dom_o(frac) ! ocean "mask" +! fractions_l(lfrin) = dom_l(frac) ! land model fraction +! then mapped to the atm model +! fractions_a(ofrac) = mapo2a(fractions_o(ofrac)) +! fractions_a(lfrin) = mapl2a(fractions_l(lfrin)) +! and a few things are then derived +! fractions_a(lfrac) = 1.0 - fractions_a(ofrac) +! this is truncated to zero for very small values (< 0.001) +! to attempt to preserve non-land gridcells. +! fractions_l(lfrac) = mapa2l(fractions_a(lfrac)) +! fractions_r(lfrac) = mapl2r(fractions_l(lfrac)) +! fractions_g(lfrac) = mapl2g(fractions_l(lfrac)) +! +! run-time (frac_set): +! update fractions on ice grid +! fractions_i(ifrac) = i2x_i(Si_ifrac) ! ice frac from ice model +! fractions_i(ofrac) = 1.0 - fractions_i(ifrac) +! note: the relative fractions are corrected to total fractions +! fractions_o(ifrac) = mapi2o(fractions_i(ifrac)) +! fractions_o(ofrac) = mapi2o(fractions_i(ofrac)) +! fractions_a(ifrac) = mapi2a(fractions_i(ifrac)) +! fractions_a(ofrac) = mapi2a(fractions_i(ofrac)) +! +! fractions used in merging are as follows +! mrg_x2a uses fractions_a(lfrac,ofrac,ifrac) +! mrg_x2o needs to use fractions_o(ofrac,ifrac) normalized to one +! normalization happens in mrg routine +! +! fraction corrections in mapping are as follows +! mapo2a uses *fractions_o(ofrac) and /fractions_a(ofrac) +! mapi2a uses *fractions_i(ifrac) and /fractions_a(ifrac) +! mapl2a uses *fractions_l(lfrin) and /fractions_a(lfrin) +! mapl2g weights by fractions_l(lfrac) with normalization, and multiplies by +! fractions_g(lfrac) +! mapa2* should use *fractions_a(afrac) and /fractions_*(afrac) but this +! has been defered since the ratio always close to 1.0 +! +! budgets use the standard afrac, ofrac, ifrac, and lfrac to compute +! +! fraction and domain checks +! initialization: +! dom_i = mapo2i(dom_o) ! lat, lon, mask, area +! where fractions_a(lfrac) > 0.0, fractions_a(lfrin) is also > 0.0 +! this ensures the land will provide data everywhere the atm needs it +! and allows the land frac to be subtlely different from the +! land fraction specified in the atm. +! dom_a = mapl2a(dom_l) ! if atm/lnd same grids +! dom_a = mapo2a(dom_o) ! if atm/ocn same grids +! dom_a = mapi2a(dom_i) ! if atm/ocn same grids +! 0.0-eps < fractions_*(*) < 1.0+eps +! run time: +! fractions_a(lfrac) + fractions_a(ofrac) + fractions_a(ifrac) ~ 1.0 +! 0.0-eps < fractions_*(*) < 1.0+eps +! +!! +! +! !REVISION HISTORY: +! 2007-may-07 - M. Vertenstein - initial port to cpl7. +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_frac_mct + +! !USES: + + use shr_kind_mod , only: R8 => SHR_KIND_R8 + use shr_sys_mod + use shr_const_mod + + use mct_mod + use seq_infodata_mod + use seq_comm_mct, only: logunit, loglevel, seq_comm_mpicom, seq_comm_iamroot, CPLID + use seq_map_mod, only: seq_map_map + use seq_map_type_mod, only: seq_map + + use prep_lnd_mod, only: prep_lnd_get_mapper_Fa2l + use prep_ocn_mod, only: prep_ocn_get_mapper_Fa2o + use prep_ocn_mod, only: prep_ocn_get_mapper_SFi2o + use prep_ice_mod, only: prep_ice_get_mapper_SFo2i + use prep_rof_mod, only: prep_rof_get_mapper_Fl2r + use prep_atm_mod, only: prep_atm_get_mapper_Fo2a + use prep_atm_mod, only: prep_atm_get_mapper_Fi2a + use prep_atm_mod, only: prep_atm_get_mapper_Fl2a + use prep_glc_mod, only: prep_glc_get_mapper_Fl2g + + use component_type_mod + + implicit none + private + save + +! !PUBLIC TYPES: + + ! none + +! !PUBLIC MEMBER FUNCTIONS: + + public seq_frac_init + public seq_frac_set + +! !PUBLIC DATA MEMBERS: + +!EOP + +! !LOCAL DATA + + integer, private :: seq_frac_debug = 1 + logical, private :: seq_frac_abort = .true. + logical, private :: seq_frac_dead + + !--- standard --- + real(r8),parameter :: eps_fracsum = 1.0e-02 ! allowed error in sum of fracs + real(r8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 + real(r8),parameter :: eps_fraclim = 1.0e-03 ! truncation limit in fractions_a(lfrac) + logical ,parameter :: atm_frac_correct = .false. ! turn on frac correction on atm grid + !--- standard plus atm fraction consistency --- + ! real(r8),parameter :: eps_fracsum = 1.0e-12 ! allowed error in sum of fracs + ! real(r8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 + ! real(r8),parameter :: eps_fraclim = 1.0e-03 ! truncation limit in fractions_a(lfrac) + ! logical ,parameter :: atm_frac_correct = .true. ! turn on frac correction on atm grid + !--- unconstrained and area conserving? --- + ! real(r8),parameter :: eps_fracsum = 1.0e-12 ! allowed error in sum of fracs + ! real(r8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 + ! real(r8),parameter :: eps_fraclim = 1.0e-20 ! truncation limit in fractions_a(lfrac) + ! logical ,parameter :: atm_frac_correct = .true. ! turn on frac correction on atm grid + + type(seq_map) , pointer :: mapper_o2a + type(seq_map) , pointer :: mapper_i2a + type(seq_map) , pointer :: mapper_l2a + type(seq_map) , pointer :: mapper_o2i + type(seq_map) , pointer :: mapper_a2o + type(seq_map) , pointer :: mapper_i2o + type(seq_map) , pointer :: mapper_a2l + type(seq_map) , pointer :: mapper_l2r + type(seq_map) , pointer :: mapper_l2g + + private seq_frac_check + +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_frac_init +! +! !DESCRIPTION: +! Initialize fraction attribute vectors and necessary ocn/ice domain +! fraction input if appropriate +! +! !REVISION HISTORY: +! 2007-may-07 - M. Vertenstein - initial cpl7 version. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_frac_init( infodata, & + atm, ice, lnd, ocn, glc, rof, wav, & + fractions_a, fractions_i, fractions_l, & + fractions_o, fractions_g, fractions_r, fractions_w) + +! !INPUT/OUTPUT PARAMETERS: + type(seq_infodata_type) , intent(in) :: infodata + type(component_type) , intent(in) :: atm + type(component_type) , intent(in) :: ice + type(component_type) , intent(in) :: lnd + type(component_type) , intent(in) :: ocn + type(component_type) , intent(in) :: glc + type(component_type) , intent(in) :: rof + type(component_type) , intent(in) :: wav + type(mct_aVect) , intent(inout) :: fractions_a ! Fractions on atm grid/decomp + type(mct_aVect) , intent(inout) :: fractions_i ! Fractions on ice grid/decomp + type(mct_aVect) , intent(inout) :: fractions_l ! Fractions on lnd grid/decomp + type(mct_aVect) , intent(inout) :: fractions_o ! Fractions on ocn grid/decomp + type(mct_aVect) , intent(inout) :: fractions_g ! Fractions on glc grid/decomp + type(mct_aVect) , intent(inout) :: fractions_r ! Fractions on rof grid/decomp + type(mct_aVect) , intent(inout) :: fractions_w ! Fractions on wav grid/decomp +!EOP + + !----- local ----- + type(mct_ggrid), pointer :: dom_a + type(mct_ggrid), pointer :: dom_i + type(mct_ggrid), pointer :: dom_l + type(mct_ggrid), pointer :: dom_o + type(mct_ggrid), pointer :: dom_g + type(mct_ggrid), pointer :: dom_r + type(mct_ggrid), pointer :: dom_w + + logical :: atm_present ! .true. => atm is present + logical :: ice_present ! .true. => ice is present + logical :: ocn_present ! .true. => ocean is present + logical :: lnd_present ! .true. => land is present + logical :: glc_present ! .true. => glc is present + logical :: rof_present ! .true. => rof is present + logical :: wav_present ! .true. => wav is present + logical :: dead_comps ! .true. => dead models present + + integer :: j,n ! indices + integer :: ka, ki, kl, ko ! indices + integer :: kf, kk, kr, kg ! indices + integer :: lsize ! local size of ice av + integer :: debug_old ! old debug value + + character(*),parameter :: fraclist_a = 'afrac:ifrac:ofrac:lfrac:lfrin' + character(*),parameter :: fraclist_o = 'afrac:ifrac:ofrac:ifrad:ofrad' + character(*),parameter :: fraclist_i = 'afrac:ifrac:ofrac' + character(*),parameter :: fraclist_l = 'afrac:lfrac:lfrin' + character(*),parameter :: fraclist_g = 'gfrac:lfrac' + character(*),parameter :: fraclist_r = 'lfrac:rfrac' + character(*),parameter :: fraclist_w = 'wfrac' + + !----- formats ----- + character(*),parameter :: subName = '(seq_frac_init) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present, & + dead_comps=dead_comps) + + dom_a => component_get_dom_cx(atm) + dom_l => component_get_dom_cx(lnd) + dom_i => component_get_dom_cx(ice) + dom_o => component_get_dom_cx(ocn) + dom_r => component_get_dom_cx(rof) + dom_g => component_get_dom_cx(glc) + dom_w => component_get_dom_cx(wav) + + debug_old = seq_frac_debug + seq_frac_debug = 2 + + ! Initialize fractions on atm grid/decomp (initialize ice fraction to zero) + + if (atm_present) then + lSize = mct_aVect_lSize(dom_a%data) + call mct_aVect_init(fractions_a,rList=fraclist_a,lsize=lsize) + call mct_aVect_zero(fractions_a) + + ka = mct_aVect_indexRa(fractions_a,"afrac",perrWith=subName) + fractions_a%rAttr(ka,:) = 1.0_r8 + endif + + ! Initialize fractions on glc grid decomp, just an initial "guess", updated later + + if (glc_present) then + lSize = mct_aVect_lSize(dom_g%data) + call mct_aVect_init(fractions_g,rList=fraclist_g,lsize=lsize) + call mct_aVect_zero(fractions_g) + + kg = mct_aVect_indexRA(fractions_g,"gfrac",perrWith=subName) + kf = mct_aVect_indexRA(dom_g%data ,"frac" ,perrWith=subName) + fractions_g%rAttr(kg,:) = dom_g%data%rAttr(kf,:) + end if + + ! Initialize fractions on land grid decomp, just an initial "guess", updated later + + if (lnd_present) then + lSize = mct_aVect_lSize(dom_l%data) + call mct_aVect_init(fractions_l,rList=fraclist_l,lsize=lsize) + call mct_aVect_zero(fractions_l) + + kk = mct_aVect_indexRA(fractions_l,"lfrin",perrWith=subName) + kf = mct_aVect_indexRA(dom_l%data ,"frac" ,perrWith=subName) + fractions_l%rAttr(kk,:) = dom_l%data%rAttr(kf,:) + + if (atm_present) then + mapper_l2a => prep_atm_get_mapper_Fl2a() + mapper_a2l => prep_lnd_get_mapper_Fa2l() + call seq_map_map(mapper_l2a, fractions_l, fractions_a, fldlist='lfrin', norm=.false.) + call seq_map_map(mapper_a2l, fractions_a, fractions_l, fldlist='afrac', norm=.false.) + endif + + end if + + ! Initialize fractions on ice grid/decomp (initialize ice fraction to zero) + + if (rof_present) then + lSize = mct_aVect_lSize(dom_r%data) + call mct_aVect_init(fractions_r,rList=fraclist_r,lsize=lsize) + call mct_aVect_zero(fractions_r) + + kr = mct_aVect_indexRa(fractions_r,"rfrac",perrWith=subName) + kf = mct_aVect_indexRA(dom_r%data ,"frac" ,perrWith=subName) + fractions_r%rAttr(kr,:) = dom_r%data%rAttr(kf,:) + end if + + ! Initialize fractions on wav grid decomp, just an initial "guess", updated later + + if (wav_present) then + lSize = mct_aVect_lSize(dom_w%data) + call mct_aVect_init(fractions_w,rList=fraclist_w,lsize=lsize) + call mct_aVect_zero(fractions_w) + fractions_w%rAttr(:,:) = 1.0_r8 + end if + + ! Initialize fractions on ice grid/decomp (initialize ice fraction to zero) + + if (ice_present) then + lSize = mct_aVect_lSize(dom_i%data) + call mct_aVect_init(fractions_i,rList=fraclist_i,lsize=lsize) + call mct_aVect_zero(fractions_i) + + ko = mct_aVect_indexRa(fractions_i,"ofrac",perrWith=subName) + kf = mct_aVect_indexRA(dom_i%data ,"frac" ,perrWith=subName) + fractions_i%rAttr(ko,:) = dom_i%data%rAttr(kf,:) + + if (atm_present) then + mapper_i2a => prep_atm_get_mapper_Fi2a() + call seq_map_map(mapper_i2a,fractions_i,fractions_a,fldlist='ofrac',norm=.false.) + endif + end if + + ! Initialize fractions on ocean grid/decomp (initialize ice fraction to zero) + ! These are initialize the same as for ice + + if (ocn_present) then + lSize = mct_aVect_lSize(dom_o%data) + call mct_aVect_init(fractions_o,rList=fraclist_o,lsize=lsize) + call mct_aVect_zero(fractions_o) + + if (ice_present) then + mapper_i2o => prep_ocn_get_mapper_SFi2o() + call seq_map_map(mapper_i2o,fractions_i,fractions_o,fldlist='ofrac',norm=.false.) + else + ko = mct_aVect_indexRa(fractions_o,"ofrac",perrWith=subName) + kf = mct_aVect_indexRA(dom_o%data ,"frac" ,perrWith=subName) + fractions_o%rAttr(ko,:) = dom_o%data%rAttr(kf,:) + mapper_o2a => prep_atm_get_mapper_Fo2a() + call seq_map_map(mapper_o2a, fractions_o, fractions_a, fldlist='ofrac',norm=.false.) + endif + + if (atm_present) then + mapper_a2o => prep_ocn_get_mapper_Fa2o() + call seq_map_map(mapper_a2o, fractions_a, fractions_o, fldlist='afrac',norm=.false.) + endif + if (ice_present) then + ! --- this should be an atm2ice call above, but atm2ice doesn't work + mapper_o2i => prep_ice_get_mapper_SFo2i() + call seq_map_map(mapper_o2i,fractions_o,fractions_i,fldlist='afrac',norm=.false.) + endif + end if + + ! --- Set ofrac and lfrac on atm grid. These should actually be mapo2a of + ! ofrac and lfrac but we can't map lfrac from o2a due to masked mapping + ! weights. So we have to settle for a residual calculation that is + ! truncated to zero to try to preserve "all ocean" cells. + + if (atm_present) then + ka = mct_aVect_indexRa(fractions_a,"afrac",perrWith=subName) + ki = mct_aVect_indexRa(fractions_a,"ifrac",perrWith=subName) + kl = mct_aVect_indexRa(fractions_a,"lfrac",perrWith=subName) + ko = mct_aVect_indexRa(fractions_a,"ofrac",perrWith=subName) + kk = mct_aVect_indexRa(fractions_a,"lfrin",perrWith=subName) + lSize = mct_aVect_lSize(fractions_a) + + if (ice_present .or. ocn_present) then + do n = 1,lsize + fractions_a%rAttr(kl,n) = 1.0_r8 - fractions_a%rAttr(ko,n) + if (abs(fractions_a%rAttr(kl,n)) < eps_fraclim) then + fractions_a%rAttr(kl,n) = 0.0_r8 + if (atm_frac_correct) fractions_a%rAttr(ko,n) = 1.0_r8 + endif + enddo + else if (lnd_present) then + do n = 1,lsize + fractions_a%rAttr(kl,n) = fractions_a%rAttr(kk,n) + fractions_a%rAttr(ko,n) = 1.0_r8 - fractions_a%rAttr(kl,n) + if (abs(fractions_a%rAttr(ko,n)) < eps_fraclim) then + fractions_a%rAttr(ko,n) = 0.0_r8 + if (atm_frac_correct) fractions_a%rAttr(kl,n) = 1.0_r8 + endif + enddo + endif + endif + + ! --- finally, set fractions_l(lfrac) from fractions_a(lfrac) + ! --- and fractions_r(lfrac) from fractions_l(lfrac) + ! --- and fractions_g(lfrac) from fractions_l(lfrac) + + if (lnd_present) then + if (atm_present) then + mapper_a2l => prep_lnd_get_mapper_Fa2l() + call seq_map_map(mapper_a2l, fractions_a, fractions_l, fldlist='lfrac', norm=.false.) + else + ! If the atmosphere is absent, then simply set fractions_l(lfrac) = fractions_l(lfrin) + kk = mct_aVect_indexRA(fractions_l,"lfrin",perrWith=subName) + kl = mct_aVect_indexRA(fractions_l,"lfrac",perrWith=subName) + fractions_l%rAttr(kl,:) = fractions_l%rAttr(kk,:) + end if + end if + if (lnd_present .and. rof_present) then + mapper_l2r => prep_rof_get_mapper_Fl2r() + call seq_map_map(mapper_l2r, fractions_l, fractions_r, fldlist='lfrac', norm=.false.) + endif + if (lnd_present .and. glc_present) then + mapper_l2g => prep_glc_get_mapper_Fl2g() + call seq_map_map(mapper_l2g, fractions_l, fractions_g, fldlist='lfrac', norm=.false.) + end if + + if (lnd_present) call seq_frac_check(fractions_l,'lnd init') + if (glc_present) call seq_frac_check(fractions_g,'glc init') + if (rof_present) call seq_frac_check(fractions_r,'rof init') + if (wav_present) call seq_frac_check(fractions_w,'wav init') + if (ice_present) call seq_frac_check(fractions_i,'ice init') + if (ocn_present) call seq_frac_check(fractions_o,'ocn init') + if (atm_present .and. (lnd_present.or.ice_present.or.ocn_present)) & + call seq_frac_check(fractions_a,'atm init') + seq_frac_debug = debug_old + +end subroutine seq_frac_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_frac_set +! +! !DESCRIPTION: +! Update surface fractions +! +! !REVISION HISTORY: +! 2007-may-07 - M. Vertenstein - initial cpl7 version. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_frac_set(infodata, ice, fractions_a, fractions_i, fractions_o) + +! !INPUT/OUTPUT PARAMETERS: + type(seq_infodata_type) , intent(in) :: infodata + type(component_type) , intent(in) :: ice + type(mct_aVect) , intent(inout) :: fractions_a ! Fractions on atm + type(mct_aVect) , intent(inout) :: fractions_i ! Fractions on ice + type(mct_aVect) , intent(inout) :: fractions_o ! Fractions on ocn +!EOP + + !----- local ----- + type(mct_aVect), pointer :: i2x_i + type(mct_ggrid), pointer :: dom_i + logical :: atm_present ! true => atm is present + logical :: ice_present ! true => ice is present + logical :: ocn_present ! true => ocn is present + integer :: j, n + integer :: ki, kl, ka, ko, kf + integer :: lsize + real(r8),allocatable :: fcorr(:) + + !----- formats ----- + character(*),parameter :: subName = '(seq_frac_set) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------- + ! Update fractions + ! - Update ice fraction on ice grid first, normalize to total fraction + ! available for cover + ! - Update ocn fraction on ice grid as residual + ! - Map ice/ocn fractions from ice grid to ocean and atm grids + !---------------------------------------------------------------------- + + call seq_infodata_getData(infodata, & + atm_present=atm_present, & + ice_present=ice_present, & + ocn_present=ocn_present) + + dom_i => component_get_dom_cx(ice) + i2x_i => component_get_c2x_cx(ice) + + if (ice_present) then + call mct_aVect_copy(i2x_i, fractions_i, "Si_ifrac", "ifrac") + + ki = mct_aVect_indexRA(fractions_i,"ifrac") + ko = mct_aVect_indexRA(fractions_i,"ofrac") + kf = mct_aVect_indexRA(dom_i%data ,"frac" ,perrWith=subName) + fractions_i%rAttr(ki,:) = fractions_i%rAttr(ki,:) * dom_i%data%rAttr(kf,:) + fractions_i%rAttr(ko,:) = dom_i%data%rAttr(kf,:) - fractions_i%rAttr(ki,:) + + call seq_frac_check(fractions_i,'ice set') + + if (ocn_present) then + mapper_i2o => prep_ocn_get_mapper_SFi2o() + call seq_map_map(mapper_i2o, fractions_i, fractions_o, & + fldlist='ofrac:ifrac',norm=.false.) + call seq_frac_check(fractions_o, 'ocn set') + endif + + if (atm_present) then + mapper_i2a => prep_atm_get_mapper_Fi2a() + call seq_map_map(mapper_i2a, fractions_i, fractions_a, & + fldlist='ofrac:ifrac', norm=.false.) + + !tcx--- fraction correction, this forces the fractions_a to sum to 1.0_r8. + ! --- but it introduces a conservation error in mapping + if (atm_frac_correct) then + ki = mct_aVect_indexRA(fractions_a,"ifrac") + ko = mct_aVect_indexRA(fractions_a,"ofrac") + kl = mct_aVect_indexRA(fractions_a,"lfrac") + lSize = mct_aVect_lSize(fractions_a) + allocate(fcorr(lsize)) + do n = 1,lsize + if ((fractions_a%rAttr(ki,n)+fractions_a%rAttr(ko,n)) > 0.0_r8) then + fcorr(n) = ((1.0_r8-fractions_a%rAttr(kl,n))/ & + (fractions_a%rAttr(ki,n)+fractions_a%rAttr(ko,n))) + else + fcorr(n) = 0.0_r8 + endif + enddo + fractions_a%rAttr(ki,:) = fractions_a%rAttr(ki,:) * fcorr(:) + fractions_a%rAttr(ko,:) = fractions_a%rAttr(ko,:) * fcorr(:) + deallocate(fcorr) + endif + + call seq_frac_check(fractions_a,'atm set') + endif + end if + +end subroutine seq_frac_set + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_frac_check +! +! !DESCRIPTION: +! Check surface fractions +! +! !REVISION HISTORY: +! 2008-jun-11 - T. Craig - initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_frac_check(fractions,string) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) , intent(in) :: fractions ! Fractions datatype + character(len=*), intent(in), optional :: string ! character string + +!EOP + + !----- local ----- + integer :: n, lsize + integer :: ncnt + integer :: mpicom + logical :: iamroot + real(r8) :: sum,diff,maxerr + real(r8) :: aminval,amaxval ! used for lnd + real(r8) :: lminval,lmaxval ! used for lnd + real(r8) :: ominval,omaxval ! used for ocn + real(r8) :: iminval,imaxval ! used for ice + real(r8) :: gminval,gmaxval ! used for glc + real(r8) :: rminval,rmaxval ! used for rof + real(r8) :: wminval,wmaxval ! used for wav + real(r8) :: kminval,kmaxval ! used for lnd, lfrin + real(r8) :: sminval,smaxval ! used for sum + real(r8) :: tmpmin, tmpmax ! global tmps + integer :: tmpsum ! global tmp + integer :: ka,kl,ki,ko,kg,kk,kr,kw + character(len=128) :: lstring + logical :: error + + !----- formats ----- + character(*),parameter :: subName = '(seq_frac_check) ' + character(*),parameter :: F01 = "('(seq_frac_check) ',2a,i8,g26.18)" + character(*),parameter :: F02 = "('(seq_frac_check) ',2a,2g26.18)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + mpicom = seq_comm_mpicom(CPLID) + iamroot = seq_comm_iamroot(CPLID) + + if (present(string)) then + lstring='['//trim(string)//']' + else + lstring='' + endif + + ka = -1 + kl = -1 + ki = -1 + ko = -1 + kk = -1 + kg = -1 + kr = -1 + kw = -1 + aminval = 999.0_r8 + amaxval = -999.0_r8 + lminval = 999.0_r8 + lmaxval = -999.0_r8 + iminval = 999.0_r8 + imaxval = -999.0_r8 + ominval = 999.0_r8 + omaxval = -999.0_r8 + gminval = 999.0_r8 + gmaxval = -999.0_r8 + kminval = 999.0_r8 + kmaxval = -999.0_r8 + sminval = 999.0_r8 + smaxval = -999.0_r8 + rminval = 999.0_r8 + rmaxval = -999.0_r8 + wminval = 999.0_r8 + wmaxval = -999.0_r8 + + lsize = mct_avect_lsize(fractions) + ka = mct_aVect_indexRA(fractions,"afrac",perrWith='quiet') + kl = mct_aVect_indexRA(fractions,"lfrac",perrWith='quiet') + ki = mct_aVect_indexRA(fractions,"ifrac",perrWith='quiet') + ko = mct_aVect_indexRA(fractions,"ofrac",perrWith='quiet') + kg = mct_aVect_indexRA(fractions,"gfrac",perrWith='quiet') + kr = mct_aVect_indexRA(fractions,"rfrac",perrWith='quiet') + kw = mct_aVect_indexRA(fractions,"wfrac",perrWith='quiet') + kk = mct_aVect_indexRA(fractions,"lfrin",perrWith='quiet') + + if (ka > 0) then + aminval = minval(fractions%rAttr(ka,:)) + amaxval = maxval(fractions%rAttr(ka,:)) + endif + if (kl > 0) then + lminval = minval(fractions%rAttr(kl,:)) + lmaxval = maxval(fractions%rAttr(kl,:)) + endif + if (ko > 0) then + ominval = minval(fractions%rAttr(ko,:)) + omaxval = maxval(fractions%rAttr(ko,:)) + endif + if (ki > 0) then + iminval = minval(fractions%rAttr(ki,:)) + imaxval = maxval(fractions%rAttr(ki,:)) + endif + if (kg > 0) then + gminval = minval(fractions%rAttr(kg,:)) + gmaxval = maxval(fractions%rAttr(kg,:)) + endif + if (kr > 0) then + rminval = minval(fractions%rAttr(kr,:)) + rmaxval = maxval(fractions%rAttr(kr,:)) + endif + if (kw > 0) then + wminval = minval(fractions%rAttr(kw,:)) + wmaxval = maxval(fractions%rAttr(kw,:)) + endif + if (kk > 0) then + kminval = minval(fractions%rAttr(kk,:)) + kmaxval = maxval(fractions%rAttr(kk,:)) + endif + + ncnt = 0 + maxerr = 0.0_r8 + if (kl > 0 .and. ko > 0 .and. ki > 0) then + do n = 1,lsize + sum = fractions%rAttr(ko,n) + fractions%rAttr(kl,n) + fractions%rAttr(ki,n) + sminval = min(sum,sminval) + smaxval = max(sum,smaxval) + diff = abs(1.0_r8 - sum) + if (diff > eps_fracsum) then + ncnt = ncnt + 1 + maxerr = max(maxerr, diff) + !tcx debug write(logunit,*) trim(lstring),' err# ',ncnt, n, lsize, & + !fractions%rAttr(ko,n),fractions%rAttr(kl,n),fractions%rAttr(ki,n),sum + endif + enddo + endif + + error = .false. + if (ncnt > 0) error = .true. + if (aminval < 0.0_r8-eps_fracval .or. amaxval > 1.0_r8+eps_fracval) error = .true. + if (lminval < 0.0_r8-eps_fracval .or. lmaxval > 1.0_r8+eps_fracval) error = .true. + if (ominval < 0.0_r8-eps_fracval .or. omaxval > 1.0_r8+eps_fracval) error = .true. + if (iminval < 0.0_r8-eps_fracval .or. imaxval > 1.0_r8+eps_fracval) error = .true. + if (gminval < 0.0_r8-eps_fracval .or. gmaxval > 1.0_r8+eps_fracval) error = .true. + if (rminval < 0.0_r8-eps_fracval .or. rmaxval > 1.0_r8+eps_fracval) error = .true. + if (wminval < 0.0_r8-eps_fracval .or. wmaxval > 1.0_r8+eps_fracval) error = .true. + if (kminval < 0.0_r8-eps_fracval .or. kmaxval > 1.0_r8+eps_fracval) error = .true. + + if (error .or. seq_frac_debug > 1) then + if (ka > 0) then + call shr_mpi_min(aminval,tmpmin,mpicom,subname//':afrac',all=.false.) + call shr_mpi_max(amaxval,tmpmax,mpicom,subname//':afrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' afrac min/max = ',tmpmin,tmpmax + endif + if (kl > 0) then + call shr_mpi_min(lminval,tmpmin,mpicom,subname//':lfrac',all=.false.) + call shr_mpi_max(lmaxval,tmpmax,mpicom,subname//':lfrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' lfrac min/max = ',tmpmin,tmpmax + endif + if (kg > 0) then + call shr_mpi_min(gminval,tmpmin,mpicom,subname//':gfrac',all=.false.) + call shr_mpi_max(gmaxval,tmpmax,mpicom,subname//':gfrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' gfrac min/max = ',tmpmin,tmpmax + endif + if (ko > 0) then + call shr_mpi_min(ominval,tmpmin,mpicom,subname//':ofrac',all=.false.) + call shr_mpi_max(omaxval,tmpmax,mpicom,subname//':ofrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' ofrac min/max = ',tmpmin,tmpmax + endif + if (ki > 0) then + call shr_mpi_min(iminval,tmpmin,mpicom,subname//':ifrac',all=.false.) + call shr_mpi_max(imaxval,tmpmax,mpicom,subname//':ifrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' ifrac min/max = ',tmpmin,tmpmax + endif + if (kr > 0) then + call shr_mpi_min(rminval,tmpmin,mpicom,subname//':rfrac',all=.false.) + call shr_mpi_max(rmaxval,tmpmax,mpicom,subname//':rfrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' rfrac min/max = ',tmpmin,tmpmax + endif + if (kw > 0) then + call shr_mpi_min(wminval,tmpmin,mpicom,subname//':wfrac',all=.false.) + call shr_mpi_max(wmaxval,tmpmax,mpicom,subname//':wfrac',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' wfrac min/max = ',tmpmin,tmpmax + endif + if (kk > 0) then + call shr_mpi_min(kminval,tmpmin,mpicom,subname//':lfrin',all=.false.) + call shr_mpi_max(kmaxval,tmpmax,mpicom,subname//':lfrin',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' lfrin min/max = ',tmpmin,tmpmax + endif + if (kl > 0 .and. ko > 0 .and. ki > 0) then + call shr_mpi_min(sminval,tmpmin,mpicom,subname//':sum',all=.false.) + call shr_mpi_max(smaxval,tmpmax,mpicom,subname//':sum',all=.false.) + if (iamroot) write(logunit,F02) trim(lstring),' sum min/max = ',tmpmin,tmpmax + call shr_mpi_sum(ncnt ,tmpsum,mpicom,subname//':sum',all=.false.) + call shr_mpi_max(maxerr,tmpmax,mpicom,subname//':sum',all=.false.) + if (iamroot) write(logunit,F01) trim(lstring),' sum ncnt/maxerr = ',tmpsum,tmpmax + endif + if (error .and. .not. seq_frac_dead .and. seq_frac_abort) then + write(logunit,F02) trim(lstring),' ERROR aborting ' + call shr_sys_abort() + elseif (error) then + if (iamroot) write(logunit,F02) trim(lstring),' ERROR but NOT aborting ' + endif + endif + +end subroutine seq_frac_check + +end module seq_frac_mct diff --git a/driver-mct/main/seq_hist_mod.F90 b/driver-mct/main/seq_hist_mod.F90 new file mode 100644 index 000000000000..e5fe1143d998 --- /dev/null +++ b/driver-mct/main/seq_hist_mod.F90 @@ -0,0 +1,1477 @@ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_hist_mod -- cpl7 history writing routines +! +! !DESCRIPTION: +! +! Creates cpl7 history files, instantanious, time-avg, and auxilliary +! +! !REVISION HISTORY: +! 2009-Sep-25 - B. Kauffman - move from cpl7 main program into hist module +! 2009-mmm-dd - T. Craig - initial versions +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_hist_mod + +! !USES: + + use shr_kind_mod, only: R8 => SHR_KIND_R8, IN => SHR_KIND_IN + use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use shr_cal_mod, only: shr_cal_date2ymd + use mct_mod ! adds mct_ prefix to mct lib + use ESMF + + use seq_infodata_mod ! "infodata" gathers various control flags into one datatype + use seq_timemgr_mod ! clock & alarm routines + use seq_io_mod ! lower level io routines + + use seq_comm_mct , only: seq_comm_getdata=>seq_comm_setptrs + use seq_comm_mct, only: seq_comm_setnthreads, seq_comm_iamin + use seq_comm_mct, only: CPLID, GLOID, logunit, loglevel + use seq_comm_mct, only: num_inst_atm, num_inst_lnd, num_inst_ocn + use seq_comm_mct, only: num_inst_ice, num_inst_glc, num_inst_wav + use seq_comm_mct, only: num_inst_rof, num_inst_xao + + use prep_ocn_mod, only: prep_ocn_get_r2x_ox + use prep_ocn_mod, only: prep_ocn_get_x2oacc_ox + use prep_ocn_mod, only: prep_ocn_get_x2oacc_ox_cnt + use prep_atm_mod, only: prep_atm_get_o2x_ax + use prep_aoflux_mod, only: prep_aoflux_get_xao_ox + use prep_aoflux_mod, only: prep_aoflux_get_xao_ax + + use component_type_mod + + implicit none + + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS + + public :: seq_hist_write ! write instantaneous hist file + public :: seq_hist_writeavg ! write time-avg hist file + public :: seq_hist_writeaux ! write auxiliary hist files + public :: seq_hist_spewav ! write avs to history file for debugging + +! !PUBLIC DATA MEMBERS: + + ! no public data + +!EOP + + !---------------------------------------------------------------------------- + ! local/module data + !---------------------------------------------------------------------------- + + logical :: iamin_CPLID ! pe associated with CPLID + integer(IN) :: mpicom_GLOID ! MPI global communicator + integer(IN) :: mpicom_CPLID ! MPI cpl communicator + + integer(IN) :: nthreads_GLOID ! OMP global number of threads + integer(IN) :: nthreads_CPLID ! OMP cpl number of threads + logical :: drv_threading ! driver threading control + + logical :: atm_present ! .true. => atm is present + logical :: lnd_present ! .true. => land is present + logical :: ice_present ! .true. => ice is present + logical :: ocn_present ! .true. => ocn is present + logical :: rof_present ! .true. => land runoff is present + logical :: glc_present ! .true. => glc is present + logical :: wav_present ! .true. => wav is present + + logical :: atm_prognostic ! .true. => atm comp expects input + logical :: lnd_prognostic ! .true. => lnd comp expects input + logical :: ice_prognostic ! .true. => ice comp expects input + logical :: ocn_prognostic ! .true. => ocn comp expects input + logical :: ocnrof_prognostic ! .true. => ocn comp expects runoff input + logical :: rof_prognostic ! .true. => rof comp expects input + logical :: glc_prognostic ! .true. => glc comp expects input + logical :: wav_prognostic ! .true. => wav comp expects input + + logical :: histavg_atm ! .true. => write atm fields to average history file + logical :: histavg_lnd ! .true. => write lnd fields to average history file + logical :: histavg_ocn ! .true. => write ocn fields to average history file + logical :: histavg_ice ! .true. => write ice fields to average history file + logical :: histavg_rof ! .true. => write rof fields to average history file + logical :: histavg_glc ! .true. => write glc fields to average history file + logical :: histavg_wav ! .true. => write wav fields to average history file + logical :: histavg_xao ! .true. => write flux xao fields to average history file + + + !--- domain equivalent 2d grid size --- + integer(IN) :: atm_nx, atm_ny ! nx,ny of 2d grid, if known + integer(IN) :: lnd_nx, lnd_ny ! nx,ny of 2d grid, if known + integer(IN) :: ice_nx, ice_ny ! nx,ny of 2d grid, if known + integer(IN) :: ocn_nx, ocn_ny ! nx,ny of 2d grid, if known + integer(IN) :: rof_nx, rof_ny ! nx,ny of 2d grid, if known + integer(IN) :: glc_nx, glc_ny ! nx,ny of 2d grid, if known + integer(IN) :: wav_nx, wav_ny ! nx,ny of 2d grid, if known + + integer(IN) :: info_debug = 0 ! local info_debug level + + !--- temporary pointers --- + type(mct_aVect), pointer :: r2x_ox(:) + type(mct_aVect), pointer :: x2oacc_ox(:) + integer , pointer :: x2oacc_ox_cnt + type(mct_aVect), pointer :: xao_ox(:) + type(mct_aVect), pointer :: xao_ax(:) + type(mct_aVect), pointer :: o2x_ax(:) + +!=============================================================================== +contains +!=============================================================================== + +subroutine seq_hist_write(infodata, EClock_d, & + atm, lnd, ice, ocn, rof, glc, wav, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, fractions_rx, & + fractions_gx, fractions_wx, cpl_inst_tag) + + implicit none + ! + ! Arguments + type(seq_infodata_type) , intent(in) :: infodata + type (ESMF_Clock) , intent(in) :: EClock_d ! driver clock + type (component_type) , intent(inout) :: atm(:) + type (component_type) , intent(inout) :: lnd(:) + type (component_type) , intent(inout) :: ice(:) + type (component_type) , intent(inout) :: ocn(:) + type (component_type) , intent(inout) :: rof(:) + type (component_type) , intent(inout) :: glc(:) + type (component_type) , intent(inout) :: wav(:) + type(mct_aVect) , intent(inout) :: fractions_ax(:) ! Fractions on atm grid/decomp + type(mct_aVect) , intent(inout) :: fractions_lx(:) ! Fractions on lnd grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ix(:) ! Fractions on ice grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ox(:) ! Fractions on ocn grid/decomp + type(mct_aVect) , intent(inout) :: fractions_rx(:) ! Fractions on rof grid/decomp + type(mct_aVect) , intent(inout) :: fractions_gx(:) ! Fractions on glc grid/decomp + type(mct_aVect) , intent(inout) :: fractions_wx(:) ! Fractions on wav grid/decomp + character(len=*) , intent(in) :: cpl_inst_tag + ! + ! Local Variables + integer(IN) :: curr_ymd ! Current date YYYYMMDD + integer(IN) :: curr_tod ! Current time-of-day (s) + integer(IN) :: start_ymd ! Starting date YYYYMMDD + integer(IN) :: start_tod ! Starting time-of-day (s) + real(r8) :: curr_time ! Time interval since reference time + integer(IN) :: yy,mm,dd ! year, month, day + integer(IN) :: fk ! index + character(CL) :: time_units ! units of time variable + character(CL) :: calendar ! calendar type + character(CL) :: case_name ! case name + character(CL) :: hist_file ! Local path to history filename + integer(IN) :: lsize ! local size of an aVect + real(r8) :: tbnds(2) ! CF1.0 time bounds + logical :: whead,wdata ! for writing restart/history cdf files + + type(mct_gsMap), pointer :: gsmap + type(mct_gGrid), pointer :: dom ! comp domain on cpl pes +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + + call seq_comm_getdata(GLOID,mpicom=mpicom_GLOID,nthreads=nthreads_GLOID) + call seq_comm_getdata(CPLID,mpicom=mpicom_CPLID,nthreads=nthreads_CPLID) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present, & + atm_prognostic=atm_prognostic, & + lnd_prognostic=lnd_prognostic, & + ice_prognostic=ice_prognostic, & + ocn_prognostic=ocn_prognostic, & + ocnrof_prognostic=ocnrof_prognostic, & + rof_prognostic=rof_prognostic, & + glc_prognostic=glc_prognostic, & + wav_prognostic=wav_prognostic, & + atm_nx=atm_nx, atm_ny=atm_ny, & + lnd_nx=lnd_nx, lnd_ny=lnd_ny, & + rof_nx=rof_nx, rof_ny=rof_ny, & + ice_nx=ice_nx, ice_ny=ice_ny, & + glc_nx=glc_nx, glc_ny=glc_ny, & + wav_nx=wav_nx, wav_ny=wav_ny, & + ocn_nx=ocn_nx, ocn_ny=ocn_ny, & + case_name=case_name) + + !--- Get current date from clock needed to label the history pointer file --- + + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=curr_ymd, curr_tod=curr_tod, & + start_ymd=start_ymd, start_tod=start_tod, curr_time=curr_time, & + calendar=calendar) + call shr_cal_date2ymd(curr_ymd,yy,mm,dd) + write(hist_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.cpl'//cpl_inst_tag//'.hi.', yy,'-',mm,'-',dd,'-',curr_tod,'.nc' + + time_units = 'days since ' & + // seq_io_date2yyyymmdd(start_ymd) // ' ' // seq_io_sec2hms(start_tod) + + if (iamin_CPLID) then + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + call seq_io_wopen(hist_file,clobber=.true.) + + ! loop twice, first time write header, second time write data for perf + + do fk = 1,2 + if (fk == 1) then + whead = .true. + wdata = .false. + elseif (fk == 2) then + whead = .false. + wdata = .true. + call seq_io_enddef(hist_file) + else + call shr_sys_abort('seq_hist_write fk illegal') + end if + + tbnds = curr_time + !------- tcx nov 2011 tbnds of same values causes problems in ferret + if (tbnds(1) >= tbnds(2)) then + call seq_io_write(hist_file,& + time_units=time_units, time_cal=calendar, time_val=curr_time, & + whead=whead, wdata=wdata) + else + call seq_io_write(hist_file, & + time_units=time_units, time_cal=calendar, time_val=curr_time, & + whead=whead, wdata=wdata, tbnds=tbnds) + endif + + if (atm_present) then + gsmap => component_get_gsmap_cx(atm(1)) + dom => component_get_dom_cx(atm(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='doma') + call seq_io_write(hist_file, gsmap, fractions_ax, 'fractions_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='fraca') + call seq_io_write(hist_file, atm, 'x2c', 'x2a_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='x2a') + call seq_io_write(hist_file, atm, 'c2x', 'a2x_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='a2x') + !call seq_io_write(hist_file, gsmap, l2x_ax, 'l2x_ax', & + ! nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='l2x_ax') + !call seq_io_write(hist_file, gsmap, o2x_ax, 'o2x_ax', & + ! nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='o2x_ax') + !call seq_io_write(hist_file, gsmap, i2x_ax, 'i2x_ax', & + ! nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='i2x_ax') + endif + + if (lnd_present) then + gsmap => component_get_gsmap_cx(lnd(1)) + dom => component_get_dom_cx(lnd(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, pre='doml') + call seq_io_write(hist_file, gsmap, fractions_lx, 'fractions_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, pre='fracl') + call seq_io_write(hist_file, lnd, 'c2x', 'l2x_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, pre='l2x') + call seq_io_write(hist_file, lnd, 'x2c', 'x2l_lx',& + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, pre='x2l') + endif + + if (rof_present) then + gsmap => component_get_gsmap_cx(rof(1)) + dom => component_get_dom_cx(rof(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, pre='domr') + call seq_io_write(hist_file, gsmap, fractions_rx, 'fractions_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, pre='fracr') + call seq_io_write(hist_file, rof, 'c2x', 'r2x_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, pre='r2x') + call seq_io_write(hist_file, rof, 'x2c', 'x2r_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, pre='x2r') + endif + + if (rof_present .and. ocnrof_prognostic) then + gsmap => component_get_gsmap_cx(ocn(1)) + r2x_ox => prep_ocn_get_r2x_ox() + call seq_io_write(hist_file, gsmap, r2x_ox, 'r2x_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='r2xo') + endif + + if (ocn_present) then + gsmap => component_get_gsmap_cx(ocn(1)) + dom => component_get_dom_cx(ocn(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='domo') + call seq_io_write(hist_file, gsmap, fractions_ox, 'fractions_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='fraco') + call seq_io_write(hist_file, ocn, 'c2x', 'o2x_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='o2x') + !call seq_io_write(hist_file, ocn, 'x2c', 'x2o_ox', & + ! nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='x2o') + + gsmap => component_get_gsmap_cx(ocn(1)) + x2oacc_ox => prep_ocn_get_x2oacc_ox() + call seq_io_write(hist_file, gsmap, x2oacc_ox, 'x2oacc_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='x2oacc') + + gsmap => component_get_gsmap_cx(ocn(1)) + x2oacc_ox_cnt => prep_ocn_get_x2oacc_ox_cnt() + call seq_io_write(hist_file, x2oacc_ox_cnt, 'x2oacc_ox_cnt', & + whead=whead, wdata=wdata) + gsmap => component_get_gsmap_cx(ocn(1)) + xao_ox => prep_aoflux_get_xao_ox() + call seq_io_write(hist_file, gsmap, xao_ox, 'xao_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='xaoo') + + gsmap => component_get_gsmap_cx(atm(1)) + o2x_ax => prep_atm_get_o2x_ax() + call seq_io_write(hist_file, gsmap, o2x_ax, 'o2x_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='o2xa') + + gsmap => component_get_gsmap_cx(atm(1)) + xao_ax => prep_aoflux_get_xao_ax() + call seq_io_write(hist_file, gsmap, xao_ax, 'xao_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='xaoa') + endif + + if (ice_present) then + gsmap => component_get_gsmap_cx(ice(1)) + dom => component_get_dom_cx(ice(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, pre='domi') + call seq_io_write(hist_file, gsmap, fractions_ix, 'fractions_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, pre='fraci') + call seq_io_write(hist_file, ice, 'c2x', 'i2x_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, pre='i2x') + call seq_io_write(hist_file, ice, 'x2c', 'x2i_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, pre='x2i') + endif + + if (glc_present) then + gsmap => component_get_gsmap_cx(glc(1)) + dom => component_get_dom_cx(glc(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, pre='domg') + call seq_io_write(hist_file, gsmap, fractions_gx, 'fractions_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, pre='fracg') + call seq_io_write(hist_file, glc, 'c2x', 'g2x_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, pre='g2x') + call seq_io_write(hist_file, glc, 'x2c', 'x2g_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, pre='x2g') + endif + + if (wav_present) then + gsmap => component_get_gsmap_cx(wav(1)) + dom => component_get_dom_cx(wav(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, pre='domw') + call seq_io_write(hist_file, gsmap, fractions_wx, 'fractions_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, pre='fracw') + call seq_io_write(hist_file, wav, 'c2x', 'w2x_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, pre='w2x') + call seq_io_write(hist_file, wav, 'x2c', 'x2w_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, pre='x2w') + endif + enddo + + call seq_io_close(hist_file) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif + +end subroutine seq_hist_write + +!=============================================================================== + +subroutine seq_hist_writeavg(infodata, EClock_d, & + atm, lnd, ice, ocn, rof, glc, wav, write_now, cpl_inst_tag) + + implicit none + + type(seq_infodata_type) , intent(in) :: infodata + type (ESMF_Clock) , intent(in) :: EClock_d ! driver clock + type (component_type) , intent(in) :: atm(:) + type (component_type) , intent(in) :: lnd(:) + type (component_type) , intent(in) :: ice(:) + type (component_type) , intent(in) :: ocn(:) + type (component_type) , intent(in) :: rof(:) + type (component_type) , intent(in) :: glc(:) + type (component_type) , intent(in) :: wav(:) + logical , intent(in) :: write_now ! write or accumulate + character(len=*) , intent(in) :: cpl_inst_tag + + integer(IN) :: curr_ymd ! Current date YYYYMMDD + integer(IN) :: curr_tod ! Current time-of-day (s) + integer(IN) :: prev_ymd ! Previous date YYYYMMDD + integer(IN) :: prev_tod ! Previous time-of-day (s) + integer(IN) :: start_ymd ! Starting date YYYYMMDD + integer(IN) :: start_tod ! Starting time-of-day (s) + real(r8) :: curr_time ! Time interval since reference time + real(r8) :: prev_time ! Time interval since reference time + real(r8) :: avg_time ! Average time of tavg + integer(IN) :: yy, mm, dd ! year, month, day + integer(IN) :: fk ! index + character(CL) :: time_units ! units of time variable + character(CL) :: calendar ! calendar type + integer(IN) :: lsize ! local size of an aVect + character(CL) :: case_name ! case name + character(CL) :: hist_file ! Local path to history filename + logical :: whead, wdata ! flags write header vs. data + integer(IN) :: iidx ! component instance counter + + type(mct_aVect), save :: a2x_ax_avg(num_inst_atm) ! tavg aVect/bundle + type(mct_aVect), save :: x2a_ax_avg(num_inst_atm) + type(mct_aVect), save :: l2x_lx_avg(num_inst_lnd) + type(mct_aVect), save :: x2l_lx_avg(num_inst_lnd) + type(mct_aVect), save :: r2x_rx_avg(num_inst_rof) + type(mct_aVect), save :: x2r_rx_avg(num_inst_rof) + type(mct_aVect), save :: o2x_ox_avg(num_inst_ocn) + type(mct_aVect), save :: x2o_ox_avg(num_inst_ocn) + type(mct_aVect), save :: i2x_ix_avg(num_inst_ice) + type(mct_aVect), save :: x2i_ix_avg(num_inst_ice) + type(mct_aVect), save :: g2x_gx_avg(num_inst_glc) + type(mct_aVect), save :: x2g_gx_avg(num_inst_glc) + type(mct_aVect), save :: w2x_wx_avg(num_inst_wav) + type(mct_aVect), save :: x2w_wx_avg(num_inst_wav) + type(mct_aVect), save, pointer :: xao_ox_avg(:) + type(mct_aVect), save, pointer :: xao_ax_avg(:) + + integer(IN) , save :: cnt ! counts samples in tavg + real(r8) , save :: tbnds(2) ! CF1.0 time bounds + + logical , save :: first_call = .true. ! flags 1st call of this routine + + type(mct_gsMap), pointer :: gsmap ! component decomp on cpl pes + type(mct_gGrid), pointer :: dom ! component domain on cpl pes + type(mct_avect), pointer :: c2x ! component->coupler avs on cpl pes + type(mct_avect), pointer :: x2c ! coupler->component avs on cpl pes +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + call seq_comm_getdata(GLOID, & + mpicom=mpicom_GLOID, nthreads=nthreads_GLOID) + call seq_comm_getdata(CPLID, & + mpicom=mpicom_CPLID, nthreads=nthreads_CPLID) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present, & + atm_prognostic=atm_prognostic, & + lnd_prognostic=lnd_prognostic, & + ice_prognostic=ice_prognostic, & + ocn_prognostic=ocn_prognostic, & + ocnrof_prognostic=ocnrof_prognostic, & + glc_prognostic=glc_prognostic, & + wav_prognostic=wav_prognostic, & + atm_nx=atm_nx, atm_ny=atm_ny, & + lnd_nx=lnd_nx, lnd_ny=lnd_ny, & + rof_nx=rof_nx, rof_ny=rof_ny, & + ice_nx=ice_nx, ice_ny=ice_ny, & + glc_nx=glc_nx, glc_ny=glc_ny, & + wav_nx=wav_nx, wav_ny=wav_ny, & + ocn_nx=ocn_nx, ocn_ny=ocn_ny, & + histavg_atm=histavg_atm, & + histavg_lnd=histavg_lnd, & + histavg_ocn=histavg_ocn, & + histavg_ice=histavg_ice, & + histavg_rof=histavg_rof, & + histavg_glc=histavg_glc, & + histavg_wav=histavg_wav, & + histavg_xao=histavg_xao) + + ! Get current date from clock needed to label the histavg pointer file + + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=curr_ymd, curr_tod=curr_tod, & + start_ymd=start_ymd, start_tod=start_tod, curr_time=curr_time, prev_time=prev_time, & + calendar=calendar) + + if (first_call) then + if (atm_present .and. histavg_atm) then + do iidx = 1, num_inst_atm + c2x => component_get_c2x_cx(atm(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(a2x_ax_avg(iidx), c2x, lsize) + call mct_aVect_zero(a2x_ax_avg(iidx)) + + x2c => component_get_x2c_cx(atm(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2a_ax_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2a_ax_avg(iidx)) + enddo + endif + if (lnd_present .and. histavg_lnd) then + do iidx = 1, num_inst_lnd + c2x => component_get_c2x_cx(lnd(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(l2x_lx_avg(iidx), c2x, lsize) + call mct_aVect_zero(l2x_lx_avg(iidx)) + + x2c => component_get_x2c_cx(lnd(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2l_lx_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2l_lx_avg(iidx)) + enddo + endif + if (rof_present .and. histavg_rof) then + do iidx = 1, num_inst_rof + c2x => component_get_c2x_cx(rof(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(r2x_rx_avg(iidx), c2x, lsize) + call mct_aVect_zero(r2x_rx_avg(iidx)) + + x2c => component_get_x2c_cx(rof(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2r_rx_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2r_rx_avg(iidx)) + enddo + endif + if (ocn_present .and. histavg_ocn) then + do iidx = 1, num_inst_ocn + c2x => component_get_c2x_cx(ocn(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(o2x_ox_avg(iidx), c2x, lsize) + call mct_aVect_zero(o2x_ox_avg(iidx)) + + x2c => component_get_x2c_cx(ocn(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2o_ox_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2o_ox_avg(iidx)) + enddo + endif + if (ice_present .and. histavg_ice) then + do iidx = 1, num_inst_ice + c2x => component_get_c2x_cx(ice(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(i2x_ix_avg(iidx), c2x, lsize) + call mct_aVect_zero(i2x_ix_avg(iidx)) + + x2c => component_get_x2c_cx(ice(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2i_ix_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2i_ix_avg(iidx)) + enddo + endif + if (glc_present .and. histavg_glc) then + do iidx = 1, num_inst_glc + c2x => component_get_c2x_cx(glc(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(g2x_gx_avg(iidx), c2x, lsize) + call mct_aVect_zero(g2x_gx_avg(iidx)) + + x2c => component_get_x2c_cx(glc(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2g_gx_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2g_gx_avg(iidx)) + enddo + endif + if (wav_present .and. histavg_wav) then + do iidx = 1, num_inst_wav + c2x => component_get_c2x_cx(wav(iidx)) + lsize = mct_aVect_lsize(c2x) + call mct_aVect_init(w2x_wx_avg(iidx), c2x, lsize) + call mct_aVect_zero(w2x_wx_avg(iidx)) + + x2c => component_get_x2c_cx(wav(iidx)) + lsize = mct_aVect_lsize(x2c) + call mct_aVect_init(x2w_wx_avg(iidx), x2c, lsize) + call mct_aVect_zero(x2w_wx_avg(iidx)) + enddo + endif + if (ocn_present .and. histavg_xao) then + allocate(xao_ox_avg(num_inst_xao)) + xao_ox => prep_aoflux_get_xao_ox() + do iidx = 1, num_inst_xao + lsize = mct_aVect_lsize(xao_ox(iidx)) + call mct_aVect_init(xao_ox_avg(iidx), xao_ox(iidx), lsize) + call mct_aVect_zero(xao_ox_avg(iidx)) + enddo + endif + if (atm_present .and. histavg_xao) then + allocate(xao_ax_avg(num_inst_xao)) + xao_ax => prep_aoflux_get_xao_ax() + do iidx = 1, num_inst_xao + lsize = mct_aVect_lsize(xao_ax(iidx)) + call mct_aVect_init(xao_ax_avg(iidx), xao_ax(iidx), lsize) + call mct_aVect_zero(xao_ax_avg(iidx)) + enddo + endif + cnt = 0 + tbnds(1) = prev_time + first_call = .false. + endif + + if (.not.write_now) then + cnt = cnt + 1 + if (atm_present .and. histavg_atm) then + do iidx = 1, num_inst_atm + c2x => component_get_c2x_cx(atm(iidx)) + x2c => component_get_x2c_cx(atm(iidx)) + a2x_ax_avg(iidx)%rAttr = a2x_ax_avg(iidx)%rAttr + c2x%rAttr + x2a_ax_avg(iidx)%rAttr = x2a_ax_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (lnd_present .and. histavg_lnd) then + do iidx = 1, num_inst_lnd + c2x => component_get_c2x_cx(lnd(iidx)) + x2c => component_get_x2c_cx(lnd(iidx)) + l2x_lx_avg(iidx)%rAttr = l2x_lx_avg(iidx)%rAttr + c2x%rAttr + x2l_lx_avg(iidx)%rAttr = x2l_lx_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (rof_present .and. histavg_rof) then + do iidx = 1, num_inst_rof + c2x => component_get_c2x_cx(rof(iidx)) + x2c => component_get_x2c_cx(rof(iidx)) + r2x_rx_avg(iidx)%rAttr = r2x_rx_avg(iidx)%rAttr + c2x%rAttr + x2r_rx_avg(iidx)%rAttr = x2r_rx_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (ocn_present .and. histavg_ocn) then + do iidx = 1, num_inst_ocn + c2x => component_get_c2x_cx(ocn(iidx)) + x2c => component_get_x2c_cx(ocn(iidx)) + o2x_ox_avg(iidx)%rAttr = o2x_ox_avg(iidx)%rAttr + c2x%rAttr + x2o_ox_avg(iidx)%rAttr = x2o_ox_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (ice_present .and. histavg_ice) then + do iidx = 1, num_inst_ice + c2x => component_get_c2x_cx(ice(iidx)) + x2c => component_get_x2c_cx(ice(iidx)) + i2x_ix_avg(iidx)%rAttr = i2x_ix_avg(iidx)%rAttr + c2x%rAttr + x2i_ix_avg(iidx)%rAttr = x2i_ix_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (glc_present .and. histavg_glc) then + do iidx = 1, num_inst_glc + c2x => component_get_c2x_cx(glc(iidx)) + x2c => component_get_x2c_cx(glc(iidx)) + g2x_gx_avg(iidx)%rAttr = g2x_gx_avg(iidx)%rAttr + c2x%rAttr + x2g_gx_avg(iidx)%rAttr = x2g_gx_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (wav_present .and. histavg_wav) then + do iidx = 1, num_inst_wav + c2x => component_get_c2x_cx(wav(iidx)) + x2c => component_get_x2c_cx(wav(iidx)) + w2x_wx_avg(iidx)%rAttr = w2x_wx_avg(iidx)%rAttr + c2x%rAttr + x2w_wx_avg(iidx)%rAttr = x2w_wx_avg(iidx)%rAttr + x2c%rAttr + enddo + endif + if (ocn_present .and. histavg_xao) then + xao_ox => prep_aoflux_get_xao_ox() + do iidx = 1, num_inst_ocn + xao_ox_avg(iidx)%rAttr = xao_ox_avg(iidx)%rAttr + xao_ox(iidx)%rAttr + enddo + endif + if (atm_present .and. histavg_xao) then + xao_ax => prep_aoflux_get_xao_ax() + do iidx = 1, num_inst_ocn + xao_ax_avg(iidx)%rAttr = xao_ax_avg(iidx)%rAttr + xao_ax(iidx)%rAttr + enddo + endif + + else + + cnt = cnt + 1 + tbnds(2) = curr_time + if (atm_present .and. histavg_atm) then + do iidx = 1, num_inst_atm + c2x => component_get_c2x_cx(atm(iidx)) + x2c => component_get_x2c_cx(atm(iidx)) + a2x_ax_avg(iidx)%rAttr = (a2x_ax_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2a_ax_avg(iidx)%rAttr = (x2a_ax_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (lnd_present .and. histavg_lnd) then + do iidx = 1, num_inst_lnd + c2x => component_get_c2x_cx(lnd(iidx)) + x2c => component_get_x2c_cx(lnd(iidx)) + l2x_lx_avg(iidx)%rAttr = (l2x_lx_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2l_lx_avg(iidx)%rAttr = (x2l_lx_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (rof_present .and. histavg_rof) then + do iidx = 1, num_inst_rof + c2x => component_get_c2x_cx(rof(iidx)) + x2c => component_get_x2c_cx(rof(iidx)) + r2x_rx_avg(iidx)%rAttr = (r2x_rx_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2r_rx_avg(iidx)%rAttr = (x2r_rx_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (ocn_present .and. histavg_ocn) then + do iidx = 1, num_inst_ocn + c2x => component_get_c2x_cx(ocn(iidx)) + x2c => component_get_x2c_cx(ocn(iidx)) + o2x_ox_avg(iidx)%rAttr = (o2x_ox_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2o_ox_avg(iidx)%rAttr = (x2o_ox_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (ice_present .and. histavg_ice) then + do iidx = 1, num_inst_ice + c2x => component_get_c2x_cx(ice(iidx)) + x2c => component_get_x2c_cx(ice(iidx)) + i2x_ix_avg(iidx)%rAttr = (i2x_ix_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2i_ix_avg(iidx)%rAttr = (x2i_ix_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (glc_present .and. histavg_glc) then + do iidx = 1, num_inst_glc + c2x => component_get_c2x_cx(glc(iidx)) + x2c => component_get_x2c_cx(glc(iidx)) + g2x_gx_avg(iidx)%rAttr = (g2x_gx_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2g_gx_avg(iidx)%rAttr = (x2g_gx_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (wav_present .and. histavg_wav) then + do iidx = 1, num_inst_wav + c2x => component_get_c2x_cx(wav(iidx)) + x2c => component_get_x2c_cx(wav(iidx)) + w2x_wx_avg(iidx)%rAttr = (w2x_wx_avg(iidx)%rAttr + c2x%rAttr) / (cnt * 1.0_r8) + x2w_wx_avg(iidx)%rAttr = (x2w_wx_avg(iidx)%rAttr + x2c%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (ocn_present .and. histavg_xao) then + xao_ox => prep_aoflux_get_xao_ox() + do iidx = 1, num_inst_ocn + xao_ox_avg(iidx)%rAttr = (xao_ox_avg(iidx)%rAttr + xao_ox(iidx)%rAttr) / (cnt * 1.0_r8) + enddo + endif + if (atm_present .and. histavg_xao) then + xao_ax => prep_aoflux_get_xao_ax() + do iidx = 1, num_inst_ocn + xao_ax_avg(iidx)%rAttr = (xao_ax_avg(iidx)%rAttr + xao_ax(iidx)%rAttr) / (cnt * 1.0_r8) + enddo + endif + + call seq_infodata_GetData( infodata, case_name=case_name) + call seq_timemgr_EClockGetData( EClock_d, prev_ymd=prev_ymd, prev_tod=prev_tod) + if (seq_timemgr_histavg_type == seq_timemgr_type_nyear) then + call shr_cal_date2ymd(prev_ymd, yy, mm, dd) + write(hist_file, "(2a, i4.4, a)") & + trim(case_name), '.cpl'//cpl_inst_tag//'.ha.', yy, '.nc' + elseif (seq_timemgr_histavg_type == seq_timemgr_type_nmonth) then + call shr_cal_date2ymd(prev_ymd, yy, mm, dd) + write(hist_file, "(2a, i4.4, a, i2.2, a)") & + trim(case_name), '.cpl'//cpl_inst_tag//'.ha.', yy, '-', mm, '.nc' + elseif (seq_timemgr_histavg_type == seq_timemgr_type_nday) then + call shr_cal_date2ymd(prev_ymd, yy, mm, dd) + write(hist_file, "(2a, i4.4, a, i2.2, a, i2.2, a)") & + trim(case_name), '.cpl'//cpl_inst_tag//'.ha.', yy, '-', mm, '-', dd, '.nc' + else + call shr_cal_date2ymd(curr_ymd, yy, mm, dd) + write(hist_file, "(2a, i4.4, a, i2.2, a, i2.2, a, i5.5, a)") & + trim(case_name), '.cpl'//cpl_inst_tag//'.ha.', yy, '-', mm, '-', dd, '-', curr_tod, '.nc' + endif + + time_units = 'days since ' & + // seq_io_date2yyyymmdd(start_ymd) // ' ' // seq_io_sec2hms(start_tod) + + if (iamin_CPLID) then + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + call seq_io_wopen(hist_file, clobber=.true.) + + ! loop twice, first time write header, second time write data for perf + + do fk = 1, 2 + if (fk == 1) then + whead = .true. + wdata = .false. + elseif (fk == 2) then + whead = .false. + wdata = .true. + call seq_io_enddef(hist_file) + else + call shr_sys_abort('seq_hist_writeavg fk illegal') + end if + + avg_time = 0.5_r8 * (tbnds(1) + tbnds(2)) + !---------- tcx nov 2011 tbnds of same values causes problems in ferret + if (tbnds(1) >= tbnds(2)) then + call seq_io_write(hist_file, & + time_units=time_units, time_cal=calendar, time_val=avg_time, & + whead=whead, wdata=wdata) + else + call seq_io_write(hist_file, & + time_units=time_units, time_cal=calendar, time_val=avg_time, & + whead=whead, wdata=wdata, tbnds=tbnds) + endif + if (atm_present .and. histavg_atm) then + gsmap => component_get_gsmap_cx(atm(1)) + dom => component_get_dom_cx(atm(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, pre='doma') + + call seq_io_write(hist_file, gsmap, x2a_ax_avg, 'x2a_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2aavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, a2x_ax_avg, 'a2x_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, & + pre='a2xavg', tavg=.true.) + endif + if (lnd_present .and. histavg_lnd) then + gsmap => component_get_gsmap_cx(lnd(1)) + dom => component_get_dom_cx(lnd(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, pre='doml') + call seq_io_write(hist_file, gsmap, l2x_lx_avg, 'l2x_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, & + pre='l2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2l_lx_avg, 'x2l_lx', & + nx=lnd_nx, ny=lnd_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2lavg', tavg=.true.) + endif + + if (rof_present .and. histavg_rof) then + gsmap => component_get_gsmap_cx(rof(1)) + dom => component_get_dom_cx(rof(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, pre='domr') + call seq_io_write(hist_file, gsmap, r2x_rx_avg, 'r2x_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, & + pre='r2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2r_rx_avg, 'x2r_rx', & + nx=rof_nx, ny=rof_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2ravg', tavg=.true.) + endif + if (ocn_present .and. histavg_ocn) then + gsmap => component_get_gsmap_cx(ocn(1)) + dom => component_get_dom_cx(ocn(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, pre='domo') + call seq_io_write(hist_file, gsmap, o2x_ox_avg, 'o2x_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, & + pre='o2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2o_ox_avg, 'x2o_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2oavg', tavg=.true.) + endif + if (ice_present .and. histavg_ice) then + gsmap => component_get_gsmap_cx(ice(1)) + dom => component_get_dom_cx(ice(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, pre='domi') + call seq_io_write(hist_file, gsmap, i2x_ix_avg, 'i2x_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, & + pre='i2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2i_ix_avg, 'x2i_ix', & + nx=ice_nx, ny=ice_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2iavg', tavg=.true.) + endif + if (glc_present .and. histavg_glc) then + gsmap => component_get_gsmap_cx(glc(1)) + dom => component_get_dom_cx(glc(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, pre='domg') + call seq_io_write(hist_file, gsmap, g2x_gx_avg, 'g2x_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, & + pre='g2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2g_gx_avg, 'x2g_gx', & + nx=glc_nx, ny=glc_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2gavg', tavg=.true.) + endif + if (wav_present .and. histavg_wav) then + gsmap => component_get_gsmap_cx(wav(1)) + dom => component_get_dom_cx(wav(1)) + call seq_io_write(hist_file, gsmap, dom%data, 'dom_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, pre='domw') + call seq_io_write(hist_file, gsmap, w2x_wx_avg, 'w2x_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, & + pre='w2xavg', tavg=.true.) + call seq_io_write(hist_file, gsmap, x2w_wx_avg, 'x2w_wx', & + nx=wav_nx, ny=wav_ny, nt=1, whead=whead, wdata=wdata, & + pre='x2wavg', tavg=.true.) + endif + if (ocn_present .and. histavg_xao) then + gsmap => component_get_gsmap_cx(ocn(1)) + call seq_io_write(hist_file, gsmap, xao_ox_avg, 'xao_ox', & + nx=ocn_nx, ny=ocn_ny, nt=1, whead=whead, wdata=wdata, & + pre='xaooavg', tavg=.true.) + endif + if (atm_present .and. histavg_xao) then + gsmap => component_get_gsmap_cx(atm(1)) + call seq_io_write(hist_file, gsmap, xao_ax_avg, 'xao_ax', & + nx=atm_nx, ny=atm_ny, nt=1, whead=whead, wdata=wdata, & + pre='xaoaavg', tavg=.true.) + endif + enddo + + call seq_io_close(hist_file) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + if (atm_present .and. histavg_atm) then + do iidx = 1, num_inst_atm + call mct_aVect_zero(a2x_ax_avg(iidx)) + call mct_aVect_zero(x2a_ax_avg(iidx)) + enddo + endif + if (lnd_present .and. histavg_lnd) then + do iidx = 1, num_inst_lnd + call mct_aVect_zero(l2x_lx_avg(iidx)) + call mct_aVect_zero(x2l_lx_avg(iidx)) + enddo + endif + if (rof_present .and. histavg_rof) then + do iidx = 1, num_inst_rof + call mct_aVect_zero(r2x_rx_avg(iidx)) + call mct_aVect_zero(x2r_rx_avg(iidx)) + enddo + endif + if (ocn_present .and. histavg_ocn) then + do iidx = 1, num_inst_ocn + call mct_aVect_zero(o2x_ox_avg(iidx)) + call mct_aVect_zero(x2o_ox_avg(iidx)) + enddo + endif + if (ice_present .and. histavg_ice) then + do iidx = 1, num_inst_ice + call mct_aVect_zero(i2x_ix_avg(iidx)) + call mct_aVect_zero(x2i_ix_avg(iidx)) + enddo + endif + if (glc_present .and. histavg_glc) then + do iidx = 1, num_inst_glc + call mct_aVect_zero(g2x_gx_avg(iidx)) + call mct_aVect_zero(x2g_gx_avg(iidx)) + enddo + endif + if (wav_present .and. histavg_wav) then + do iidx = 1, num_inst_wav + call mct_aVect_zero(w2x_wx_avg(iidx)) + call mct_aVect_zero(x2w_wx_avg(iidx)) + enddo + endif + if (ocn_present .and. histavg_xao) then + do iidx = 1, num_inst_xao + call mct_aVect_zero(xao_ox_avg(iidx)) + enddo + endif + if (atm_present .and. histavg_xao) then + do iidx = 1, num_inst_xao + call mct_aVect_zero(xao_ax_avg(iidx)) + enddo + endif + cnt = 0 + tbnds(1) = curr_time + + endif + endif + +end subroutine seq_hist_writeavg + +!=============================================================================== + +subroutine seq_hist_writeaux(infodata, EClock_d, comp, flow, aname, dname, & + nx, ny, nt, write_now, flds, yr_offset) + + implicit none + + !--- arguments --- + type (seq_infodata_type) , intent(inout) :: infodata + type(ESMF_Clock) , intent(in) :: EClock_d ! driver clock + type(component_type) , intent(in) :: comp ! component instance + character(len=3) , intent(in) :: flow ! 'x2c' or 'c2x' + character(*) , intent(in) :: aname ! avect name for hist file + character(*) , intent(in) :: dname ! domain name for hist file + integer(IN) , intent(in) :: nx ! 2d global size nx + integer(IN) , intent(in) :: ny ! 2d global size ny + integer(IN) , intent(in) :: nt ! number of time samples per file + logical , optional, intent(in) :: write_now ! write a sample now, if not used, write every call + character(*) , optional, intent(in) :: flds ! list of fields to write + integer , optional, intent(in) :: yr_offset ! offset to apply to current year when generating file name + + !--- local --- + type(mct_gGrid), pointer :: dom + type(mct_avect), pointer :: av + type(mct_gsMap), pointer :: gsmap + character(CL) :: case_name ! case name + integer(IN) :: curr_ymd ! Current date YYYYMMDD + integer(IN) :: curr_tod ! Current time-of-day (s) + integer(IN) :: start_ymd ! Starting date YYYYMMDD + integer(IN) :: start_tod ! Starting time-of-day (s) + real(r8) :: curr_time ! Time interval since reference time + real(r8) :: prev_time ! Time interval since reference time + real(r8) :: avg_time ! Average time for time average + integer(IN) :: yy, mm, dd ! year, month, day + integer(IN) :: n, fk, fk1 ! index + character(CL) :: time_units ! units of time variable + character(CL) :: calendar ! calendar type + integer(IN) :: samples_per_file + integer(IN) :: lsize ! local size of an aVect + logical :: first_call + integer(IN) :: found = -10 + logical :: useavg + logical :: lwrite_now + logical :: whead, wdata ! for writing restart/history cdf files + real(r8) :: tbnds(2) + + integer(IN), parameter :: maxout = 20 + integer(IN) , save :: ntout = 0 + character(CS) , save :: tname(maxout) = 'x1y2z3' + integer(IN) , save :: ncnt(maxout) = -10 + character(CL) , save :: hist_file(maxout) ! local path to history filename + type(mct_aVect) , save :: avavg(maxout) ! av accumulator if needed + integer(IN) , save :: avcnt(maxout) = 0 ! accumulator counter + logical , save :: fwrite(maxout) = .true. ! first write + real(r8) , save :: tbnds1(maxout) ! first time_bnds + real(r8) , save :: tbnds2(maxout) ! second time_bnds + + type(mct_aVect) :: avflds ! non-avg av for a subset of fields + + real(r8), parameter :: c0 = 0.0_r8 ! zero + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + + call seq_comm_getdata(GLOID, & + mpicom=mpicom_GLOID, nthreads=nthreads_GLOID) + call seq_comm_getdata(CPLID, & + mpicom=mpicom_CPLID, nthreads=nthreads_CPLID) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present) + + lwrite_now = .true. + useavg = .false. + if (present(write_now)) then + useavg = .true. + lwrite_now = write_now + endif + + call seq_timemgr_EClockGetData( EClock_d, & + curr_ymd=curr_ymd, & + curr_tod=curr_tod, & + start_ymd=start_ymd, & + start_tod=start_tod, & + curr_time=curr_time, & + prev_time=prev_time, & + calendar=calendar) + + first_call = .true. + do n = 1, ntout + if (trim(tname(n)) == trim(aname)) then + first_call = .false. + found = n + endif + enddo + + if (iamin_CPLID) then + if (flow == 'c2x') then + av => component_get_c2x_cx(comp) + else if (flow == 'x2c') then + av => component_get_x2c_cx(comp) + end if + dom => component_get_dom_cx(comp) + gsmap => component_get_gsmap_cx(comp) + end if + + if (first_call) then + ntout = ntout + 1 + if (ntout > maxout) then + write(logunit, *) 'write_history_writeaux maxout exceeded', ntout, maxout + call shr_sys_abort() + endif + tname(ntout) = trim(aname) + ncnt(ntout) = -10 + if (iamin_CPLID .and. useavg) then + lsize = mct_aVect_lsize(av) + call mct_aVect_init(avavg(ntout), av, lsize) + call mct_aVect_zero(avavg(ntout)) + avcnt(ntout) = 0 + endif + tbnds1(ntout) = prev_time + found = ntout + endif + + if (iamin_CPLID) then !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + samples_per_file = nt + + if (useavg) then + if (lwrite_now) then + avcnt(found) = avcnt(found) + 1 + avavg(found)%rAttr = (avavg(found)%rAttr + av%rAttr) / (avcnt(found) * 1.0_r8) + else + avcnt(found) = avcnt(found) + 1 + avavg(found)%rAttr = avavg(found)%rAttr + av%rAttr + endif + endif + + if (lwrite_now) then + + ncnt(found) = ncnt(found) + 1 + if (ncnt(found) < 1 .or. ncnt(found) > samples_per_file) ncnt(found) = 1 + + time_units = 'days since ' & + // seq_io_date2yyyymmdd(start_ymd) // ' ' // seq_io_sec2hms(start_tod) + tbnds2(found) = curr_time + + if (ncnt(found) == 1) then + fk1 = 1 + call seq_infodata_GetData( infodata, case_name=case_name) + call shr_cal_date2ymd(curr_ymd, yy, mm, dd) + + ! Adjust yyyy in file name by yr_offset, if present + ! For example, for a field written once a year, this will make it so the file + ! with fields from year 1 has time stamp 0001-01-01 rather than 0002-01-01, + ! which can simplify later reading by a data model + if (present(yr_offset)) then + yy = yy + yr_offset + end if + + write(hist_file(found), "(a, i4.4, a, i2.2, a, i2.2, a)") & + trim(case_name)//'.cpl.h'//trim(aname)//'.', yy, '-', mm, '-', dd, '.nc' + else + fk1 = 2 + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (fk1 == 1) then + call seq_io_wopen(hist_file(found), clobber=.true., file_ind=found) + endif + + ! loop twice, first time write header, second time write data for perf + + tbnds(1) = tbnds1(found) + tbnds(2) = tbnds2(found) + + do fk = fk1, 2 + if (fk == 1) then + whead = .true. + wdata = .false. + elseif (fk == 2) then + whead = .false. + wdata = .true. + else + call shr_sys_abort('seq_hist_writeaux fk illegal') + end if + + if (present(flds)) then + if (fk == fk1) then + lsize = mct_aVect_lsize(av) + call mct_aVect_init(avflds, rList=flds, lsize=lsize) + call mct_aVect_zero(avflds) + end if + end if + + avg_time = 0.5_r8 * (tbnds(1) + tbnds(2)) + !------- tcx nov 2011 tbnds of same values causes problems in ferret + if (tbnds(1) >= tbnds(2)) then + call seq_io_write(hist_file(found), & + time_units=time_units, time_cal=calendar, time_val=avg_time, & + nt=ncnt(found), whead=whead, wdata=wdata, file_ind=found) + else + call seq_io_write(hist_file(found), & + time_units=time_units, time_cal=calendar, time_val=avg_time, & + nt=ncnt(found), whead=whead, wdata=wdata, tbnds=tbnds, file_ind=found) + endif + + if (fwrite(found)) then + call seq_io_write(hist_file(found), gsmap, dom%data, trim(dname), & + nx=nx, ny=ny, whead=whead, wdata=wdata, fillval=c0, pre=trim(dname), file_ind=found) + endif + + if (useavg) then + if (present(flds)) then + call mct_aVect_copy(aVin=avavg(found), aVout=avflds) + call seq_io_write(hist_file(found), gsmap, avflds, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, & + pre=trim(aname), tavg=.true., use_float=.true., file_ind=found) + else + call seq_io_write(hist_file(found), gsmap, avavg(found), trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, & + pre=trim(aname), tavg=.true., use_float=.true., file_ind=found) + end if + else if (present(flds)) then + call mct_aVect_copy(aVin=av, aVout=avflds) + call seq_io_write(hist_file(found), gsmap, avflds, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, pre=trim(aname), & + use_float=.true., file_ind=found) + else + call seq_io_write(hist_file(found), gsmap, av, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, pre=trim(aname), & + use_float=.true., file_ind=found) + endif + + if (present(flds)) then + if (fk == 2) then + call mct_aVect_clean(avflds) + end if + end if + + if (fk == 1) then + call seq_io_enddef(hist_file(found), file_ind=found) + end if + + if (fk == 2) then + fwrite(found) = .false. + if (useavg) then + call mct_aVect_zero(avavg(found)) + avcnt(found) = 0 + endif + tbnds1(found) = curr_time + endif + + enddo ! fk=1,2 + + if (ncnt(found) == nt) then + call seq_io_close(hist_file(found), file_ind=found) + end if + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + endif ! lwrite_now + + endif ! iamin_CPLID <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end subroutine seq_hist_writeaux + +!=============================================================================== + +subroutine seq_hist_spewav(infodata, aname, gsmap, av, nx, ny, nt, write_now, flds) + + implicit none + + type(seq_infodata_type) , intent(in) :: infodata + character(*) , intent(in) :: aname ! avect name for hist file + type(mct_gsmap) , intent(in) :: gsmap ! gsmap + type(mct_aVect) , intent(in) :: av ! avect + integer(IN) , intent(in) :: nx ! 2d global size nx + integer(IN) , intent(in) :: ny ! 2d global size ny + integer(IN) , intent(in) :: nt ! number of time samples per file + logical , intent(in), optional :: write_now ! write a sample now, if not used, write every call + character(*) , intent(in), optional :: flds ! list of fields to write + + !--- local --- + character(CL) :: case_name ! case name + integer(IN) :: n,fk,fk1 ! index + integer(IN) :: samples_per_file + integer(IN) :: lsize ! local size of an aVect + logical :: first_call + integer(IN) :: found = -10 + logical :: useavg + logical :: lwrite_now + logical :: whead,wdata ! for writing restart/history cdf files + real(r8) :: tbnds(2) + + integer(IN),parameter :: maxout = 20 + integer(IN) ,save :: ntout = 0 + character(CS) ,save :: tname(maxout) = 'x1y2z3' + integer(IN) ,save :: ncnt(maxout) = -10 + integer(IN) ,save :: nfiles(maxout) = 0 + character(CL) ,save :: hist_file(maxout) ! local path to history filename + type(mct_aVect) ,save :: avavg(maxout) ! av accumulator if needed + integer(IN) ,save :: avcnt(maxout) = 0 ! accumulator counter + logical ,save :: fwrite(maxout) = .true. ! first write + + type(mct_aVect) :: avflds ! non-avg av for a subset of fields + + real(r8),parameter :: c0 = 0.0_r8 ! zero + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + + call seq_comm_getdata(GLOID, mpicom=mpicom_GLOID, nthreads=nthreads_GLOID) + call seq_comm_getdata(CPLID, mpicom=mpicom_CPLID, nthreads=nthreads_CPLID) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present) + + lwrite_now = .true. + useavg = .false. + if (present(write_now)) then + useavg = .true. + lwrite_now = write_now + endif + + first_call = .true. + do n = 1, ntout + if (trim(tname(n)) == trim(aname)) then + first_call = .false. + found = n + endif + enddo + + if (first_call) then + ntout = ntout + 1 + if (ntout > maxout) then + write(logunit, *) 'write_history_spewAV maxout exceeded', ntout, maxout + call shr_sys_abort() + endif + tname(ntout) = trim(aname) + ncnt(ntout) = -10 + nfiles(ntout) = 0 + if (iamin_CPLID .and. useavg) then + lsize = mct_aVect_lsize(av) + call mct_aVect_init(avavg(ntout), av, lsize) + call mct_aVect_zero(avavg(ntout)) + avcnt(ntout) = 0 + endif + found = ntout + endif + +! if (.not. iamin_CPLID) return + if (iamin_CPLID) then !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + samples_per_file = nt + + if (useavg) then + if (lwrite_now) then + avcnt(found) = avcnt(found) + 1 + avavg(found)%rAttr = (avavg(found)%rAttr + av%rAttr) / (avcnt(found) * 1.0_r8) + else + avcnt(found) = avcnt(found) + 1 + avavg(found)%rAttr = avavg(found)%rAttr + av%rAttr + endif + endif + + if (lwrite_now) then + + ncnt(found) = ncnt(found) + 1 + if (ncnt(found) < 1 .or. ncnt(found) > samples_per_file) then + ncnt(found) = 1 + nfiles(found) = nfiles(found) + 1 + endif + + if (ncnt(found) == 1) then + fk1 = 1 + call seq_infodata_GetData( infodata, case_name=case_name) + write(hist_file(found), "(a, i4.4, a)") & + trim(case_name)//'.cpl.h'//trim(aname)//'.', nfiles(found), '.nc' + else + fk1 = 2 + endif + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (fk1 == 1) then + call seq_io_wopen(hist_file(found), clobber=.true.) + else + call seq_io_wopen(hist_file(found), clobber=.false.) + endif + + ! loop twice, first time write header, second time write data for perf + + do fk = fk1, 2 + if (fk == 1) then + whead = .true. + wdata = .false. + elseif (fk == 2) then + whead = .false. + wdata = .true. + else + call shr_sys_abort('seq_hist_spewav fk illegal') + end if + + if (present(flds)) then + if (fk == fk1) then + lsize = mct_aVect_lsize(av) + call mct_aVect_init(avflds, rList=flds, lsize=lsize) + call mct_aVect_zero(avflds) + end if + end if + + tbnds = real(ncnt(found), r8) + !------- tcx nov 2011 tbnds of same values causes problems in ferret + if (tbnds(1) >= tbnds(2)) then + call seq_io_write(hist_file(found), & + time_units='nstep', time_cal='nstep', time_val=real(ncnt(found), r8), & + nt=ncnt(found), whead=whead, wdata=wdata) + else + call seq_io_write(hist_file(found), & + time_units='nstep', time_cal='nstep', time_val=real(ncnt(found), r8), & + nt=ncnt(found), whead=whead, wdata=wdata, tbnds=tbnds) + endif + + if (useavg) then + if (present(flds)) then + call mct_aVect_copy(aVin=avavg(found), aVout=avflds) + call seq_io_write(hist_file(found), gsmap, avflds, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, & + pre=trim(aname), tavg=.true., use_float=.true.) + else + call seq_io_write(hist_file(found), gsmap, avavg(found), trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, & + pre=trim(aname), tavg=.true., use_float=.true.) + end if + else if (present(flds)) then + call mct_aVect_copy(aVin=av, aVout=avflds) + call seq_io_write(hist_file(found), gsmap, avflds, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, pre=trim(aname), & + use_float=.true.) + else + call seq_io_write(hist_file(found), gsmap, av, trim(aname), & + nx=nx, ny=ny, nt=ncnt(found), whead=whead, wdata=wdata, pre=trim(aname), & + use_float=.true.) + endif + + if (present(flds)) then + if (fk == 2) then + call mct_aVect_clean(avflds) + end if + end if + + if (fk == 1) call seq_io_enddef(hist_file(found)) + if (fk == 2) then + fwrite(found) = .false. + if (useavg) then + call mct_aVect_zero(avavg(found)) + avcnt(found) = 0 + endif + endif + enddo + + call seq_io_close(hist_file(found)) + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + endif ! lwrite_now + + endif ! iamin_CPLID <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end subroutine seq_hist_spewav + +!=============================================================================== + +end module seq_hist_mod diff --git a/driver-mct/main/seq_io_mod.F90 b/driver-mct/main/seq_io_mod.F90 new file mode 100644 index 000000000000..4e878918636f --- /dev/null +++ b/driver-mct/main/seq_io_mod.F90 @@ -0,0 +1,2271 @@ +!=============================================================================== +! SVN $Id: seq_io_mod.F90 68253 2015-02-18 22:24:57Z mvertens $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/drv/seq_mct/trunk_tags/drvseq5_1_15/driver/seq_io_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_io_mod -- reads and writes driver files +! +! !DESCRIPTION: +! Writes attribute vectors to netcdf +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2007-Oct-26 - T. Craig first version +! 2007-Dec-06 - T. Craig update and improve +! 2008-Feb-16 - J. Edwards convert to PIO +! 2010-Nov - J. Edwards move PIO init and namelists from components to driver +! Current Problems +! - the original use of seq_io will now ONLY work with the cpl because +! of hardwiring cpl_io_type and cpl_io_iosystem. want the original +! io capabilities to be usable by any component +! - the init1 method depends on seq_comm for name consistency but seq_comm_init +! wants to be called after init1 so the global_comm can be modified for +! async IO. this needs to be reconciled. +! - this routine stores information for all components but most methods are +! hardwired to work only for the coupler. should all the components info +! be stored here or should this be more a general set of methods that are +! reusable as it's original intent. +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_io_mod + + ! !USES: + + use shr_kind_mod, only: r4 => shr_kind_r4, r8 => shr_kind_r8, in => shr_kind_in + use shr_kind_mod, only: cl => shr_kind_cl, cs => shr_kind_cs + use shr_sys_mod, only: shr_sys_abort + use seq_comm_mct, only: logunit, CPLID, seq_comm_setptrs + use seq_comm_mct, only: seq_comm_namelen, seq_comm_name + use seq_flds_mod, only : seq_flds_lookup + use mct_mod ! mct wrappers + use pio + use component_type_mod + + implicit none + private + +! !PUBLIC TYPES: + + ! none + +! !PUBLIC MEMBER FUNCTIONS: + + public seq_io_wopen + public seq_io_close + public seq_io_redef + public seq_io_enddef + public seq_io_date2yyyymmdd + public seq_io_sec2hms + public seq_io_read + public seq_io_write + public seq_io_cpl_init +! !PUBLIC DATA MEMBERS + + + ! none + +!EOP + + interface seq_io_read + module procedure seq_io_read_av + module procedure seq_io_read_avs + module procedure seq_io_read_avscomp + module procedure seq_io_read_int + module procedure seq_io_read_int1d + module procedure seq_io_read_r8 + module procedure seq_io_read_r81d + module procedure seq_io_read_char + end interface + interface seq_io_write + module procedure seq_io_write_av + module procedure seq_io_write_avs + module procedure seq_io_write_avscomp + module procedure seq_io_write_int + module procedure seq_io_write_int1d + module procedure seq_io_write_r8 + module procedure seq_io_write_r81d + module procedure seq_io_write_char + module procedure seq_io_write_time + end interface + +!------------------------------------------------------------------------------- +! Local data +!------------------------------------------------------------------------------- + + character(*),parameter :: prefix = "seq_io_" + real(r8) ,parameter :: fillvalue = SHR_CONST_SPVAL + character(*),parameter :: modName = "(seq_io_mod) " + integer(in) ,parameter :: debug = 1 ! internal debug level + character(*),parameter :: version ='cpl7v10' + character(*),parameter :: version0='cpl7v00' + integer(in), parameter :: file_desc_t_cnt = 20 ! Note - this is hard-wired for now + + character(CL) :: wfilename = '' + type(file_desc_t), save :: cpl_io_file(0:file_desc_t_cnt) + integer(IN) :: cpl_pio_iotype + integer(IN) :: cpl_pio_ioformat + type(iosystem_desc_t), pointer :: cpl_io_subsystem + + character(CL) :: charvar ! buffer for string read/write + integer(IN) :: io_comm + +!================================================================================= +contains +!================================================================================= + + subroutine seq_io_cpl_init() + use shr_pio_mod, only: shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat + + cpl_io_subsystem=>shr_pio_getiosys(CPLID) + cpl_pio_iotype = shr_pio_getiotype(CPLID) + cpl_pio_ioformat = shr_pio_getioformat(CPLID) + + end subroutine seq_io_cpl_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_io_wopen - open netcdf file +! +! !DESCRIPTION: +! open netcdf file +! +! !REVISION HISTORY: +! 2007-Oct-26 - T. Craig - initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_io_wopen(filename,clobber,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(*),intent(in) :: filename + logical,optional,intent(in):: clobber + integer,optional,intent(in):: file_ind + + !EOP + + logical :: exists + logical :: lclobber + integer :: iam,mpicom + integer :: rcode + integer :: nmode + integer :: lfile_ind + character(CL) :: lversion + character(*),parameter :: subName = '(seq_io_wopen) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lversion=trim(version0) + + lclobber = .false. + if (present(clobber)) lclobber=clobber + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + + if (.not. pio_file_is_open(cpl_io_file(lfile_ind))) then + ! filename not open + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_wopen exists') + if (exists) then + if (lclobber) then + nmode = pio_clobber + + ! only applies to classic NETCDF files. + if(cpl_pio_iotype == PIO_IOTYPE_NETCDF .or. & + cpl_pio_iotype == PIO_IOTYPE_PNETCDF) then + nmode = ior(nmode,cpl_pio_ioformat) + endif + + rcode = pio_createfile(cpl_io_subsystem, cpl_io_file(lfile_ind), cpl_pio_iotype, trim(filename), nmode) + if(iam==0) write(logunit,*) subname,' create file ',trim(filename) + rcode = pio_put_att(cpl_io_file(lfile_ind),pio_global,"file_version",version) + else + + rcode = pio_openfile(cpl_io_subsystem, cpl_io_file(lfile_ind), cpl_pio_iotype, trim(filename), pio_write) + if(iam==0) write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(cpl_io_file(lfile_ind),PIO_BCAST_ERROR) + rcode = pio_get_att(cpl_io_file(lfile_ind),pio_global,"file_version",lversion) + call pio_seterrorhandling(cpl_io_file(lfile_ind),PIO_INTERNAL_ERROR) + if (trim(lversion) /= trim(version)) then + rcode = pio_redef(cpl_io_file(lfile_ind)) + rcode = pio_put_att(cpl_io_file(lfile_ind),pio_global,"file_version",version) + rcode = pio_enddef(cpl_io_file(lfile_ind)) + endif + endif + else + nmode = pio_noclobber + ! only applies to classic NETCDF files. + if(cpl_pio_iotype == PIO_IOTYPE_NETCDF .or. & + cpl_pio_iotype == PIO_IOTYPE_PNETCDF) then + nmode = ior(nmode,cpl_pio_ioformat) + endif + rcode = pio_createfile(cpl_io_subsystem, cpl_io_file(lfile_ind), cpl_pio_iotype, trim(filename), nmode) + if(iam==0) write(logunit,*) subname,' create file ',trim(filename) + rcode = pio_put_att(cpl_io_file(lfile_ind),pio_global,"file_version",version) + endif + elseif (trim(wfilename) /= trim(filename)) then + ! filename is open, better match open filename + if(iam==0) write(logunit,*) subname,' different file currently open ',trim(filename) + call shr_sys_abort(subname//'different file currently open '//trim(filename)) + else + ! filename is already open, just return + endif + +end subroutine seq_io_wopen + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_io_close - close netcdf file +! +! !DESCRIPTION: +! close netcdf file +! +! !REVISION HISTORY: +! 2007-Oct-26 - T. Craig - initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_io_close(filename,file_ind) + + use pio, only : pio_closefile + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(*),intent(in) :: filename + integer,optional,intent(in):: file_ind + + !EOP + + integer :: iam + integer :: lfile_ind + integer :: rcode + character(*),parameter :: subName = '(seq_io_close) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (.not. pio_file_is_open(cpl_io_file(lfile_ind))) then + ! filename not open, just return + elseif (trim(wfilename) /= trim(filename)) then + ! filename matches, close it + call pio_closefile(cpl_io_file(lfile_ind)) + else + ! different filename is open, abort + if(iam==0) write(logunit,*) subname,' different file currently open, aborting ',trim(filename) + call shr_sys_abort(subname//'different file currently open, aborting '//trim(filename)) + endif + + wfilename = '' + +end subroutine seq_io_close + +!=============================================================================== + +subroutine seq_io_redef(filename,file_ind) + character(len=*), intent(in) :: filename + + integer,optional,intent(in):: file_ind + integer :: lfile_ind + integer :: rcode + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + rcode = pio_redef(cpl_io_file(lfile_ind)) +end subroutine seq_io_redef + +!=============================================================================== + +subroutine seq_io_enddef(filename,file_ind) + character(len=*), intent(in) :: filename + integer,optional,intent(in):: file_ind + integer :: lfile_ind + integer :: rcode + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + rcode = pio_enddef(cpl_io_file(lfile_ind)) +end subroutine seq_io_enddef + +!=============================================================================== + +character(len=10) function seq_io_date2yyyymmdd (date) + +! Input arguments + + integer, intent(in) :: date + +! Local workspace + + integer :: year ! year of yyyy-mm-dd + integer :: month ! month of yyyy-mm-dd + integer :: day ! day of yyyy-mm-dd + +!------------------------------------------------------------------------------- + + if (date < 0) then + call shr_sys_abort ('seq_io_date2yyyymmdd: negative date not allowed') + end if + + year = date / 10000 + month = (date - year*10000) / 100 + day = date - year*10000 - month*100 + + write(seq_io_date2yyyymmdd,80) year, month, day +80 format(i4.4,'-',i2.2,'-',i2.2) + +end function seq_io_date2yyyymmdd + +!=============================================================================== + +character(len=8) function seq_io_sec2hms (seconds) + +! Input arguments + + integer, intent(in) :: seconds + +! Local workspace + + integer :: hours ! hours of hh:mm:ss + integer :: minutes ! minutes of hh:mm:ss + integer :: secs ! seconds of hh:mm:ss + +!------------------------------------------------------------------------------- + + if (seconds < 0 .or. seconds > 86400) then + write(logunit,*)'seq_io_sec2hms: bad input seconds:', seconds + call shr_sys_abort('seq_io_sec2hms: bad input seconds') + end if + + hours = seconds / 3600 + minutes = (seconds - hours*3600) / 60 + secs = (seconds - hours*3600 - minutes*60) + + if (minutes < 0 .or. minutes > 60) then + write(logunit,*)'seq_io_sec2hms: bad minutes = ',minutes + call shr_sys_abort('seq_io_sec2hms: bad minutes') + end if + + if (secs < 0 .or. secs > 60) then + write(logunit,*)'seq_io_sec2hms: bad secs = ',secs + call shr_sys_abort('seq_io_sec2hms: bad secs') + end if + + write(seq_io_sec2hms,80) hours, minutes, secs +80 format(i2.2,':',i2.2,':',i2.2) + +end function seq_io_sec2hms + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_av - write AV to netcdf file + ! + ! !DESCRIPTION: + ! Write AV to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_av(filename,gsmap,AV,dname,whead,wdata,nx,ny,nt,fillval,pre,tavg,& + use_float, file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(mct_gsMap), intent(in) :: gsmap + type(mct_aVect) ,intent(in) :: AV ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer(in),optional,intent(in) :: nx ! 2d grid size if available + integer(in),optional,intent(in) :: ny ! 2d grid size if available + integer(in),optional,intent(in) :: nt ! time sample + real(r8),optional,intent(in) :: fillval ! fill value + character(len=*),optional,intent(in) :: pre ! prefix to variable name + logical,optional,intent(in) :: tavg ! is this a tavg + logical,optional,intent(in) :: use_float ! write output as float rather than double + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: mpicom + integer(in) :: iam + integer(in) :: nf,ns,ng + integer(in) :: i,j,k,n + integer(in),target :: dimid2(2) + integer(in),target :: dimid3(3) + integer(in),pointer :: dimid(:) + type(var_desc_t) :: varid + type(io_desc_t) :: iodesc + integer(kind=Pio_Offset_Kind) :: frame + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + character(CL) :: name1 ! var name + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + character(CL) :: lpre ! local prefix + logical :: exists + logical :: lwhead, lwdata + logical :: luse_float + integer(in) :: lnx,lny + real(r8) :: lfillvalue + character(*),parameter :: subName = '(seq_io_write_av) ' + integer :: lbnum + integer, pointer :: Dof(:) + integer :: lfile_ind + + real(r8), allocatable :: tmpdata(:) + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lfillvalue = fillvalue + if (present(fillval)) then + lfillvalue = fillval + endif + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + luse_float = .false. + if (present(use_float)) luse_float = use_float + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + ng = mct_gsmap_gsize(gsmap) + lnx = ng + lny = 1 + + nf = mct_aVect_nRattr(AV) + if (nf < 1) then + write(logunit,*) subname,' ERROR: nf = ',nf,trim(dname) + call shr_sys_abort(subname//'nf error') + endif + frame = -1 + if (present(nt)) then + frame = nt + endif + if (present(nx)) then + if (nx /= 0) lnx = nx + endif + if (present(ny)) then + if (ny /= 0) lny = ny + endif + if (lnx*lny /= ng) then + if(iam==0) write(logunit,*) subname,' ERROR: grid2d size not consistent ',ng,lnx,lny,trim(dname) + call shr_sys_abort(subname//'ERROR: grid2d size not consistent ') + endif + + if (lwhead) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_nx',lnx,dimid2(1)) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_ny',lny,dimid2(2)) + + if (present(nt)) then + dimid3(1:2) = dimid2 + rcode = pio_inq_dimid(cpl_io_file(lfile_ind),'time',dimid3(3)) + dimid => dimid3 + else + dimid => dimid2 + endif + + do k = 1,nf + call mct_aVect_getRList(mstring,k,AV) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + call seq_flds_lookup(itemc,longname=lname,stdname=sname,units=cunit) + if (luse_float) then + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_REAL,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",real(lfillvalue,r4)) + else + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_DOUBLE,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",lfillvalue) + end if + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"internal_dname",trim(dname)) + if (present(tavg)) then + if (tavg) then + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"cell_methods","time: mean") + endif + endif +!-------tcraig + endif + enddo + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + end if + + if (lwdata) then + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + ns = size(dof) + deallocate(dof) + allocate(tmpdata(ns)) + do k = 1,nf + call mct_aVect_getRList(mstring,k,AV) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(name1),varid) + call pio_setframe(cpl_io_file(lfile_ind),varid,frame) + tmpdata = av%rattr(k,:) + call pio_write_darray(cpl_io_file(lfile_ind), varid, iodesc, tmpdata, rcode, fillval=lfillvalue) +!-------tcraig + endif + enddo + deallocate(tmpdata) + call pio_freedecomp(cpl_io_file(lfile_ind), iodesc) + + end if + end subroutine seq_io_write_av + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_avs - write AVS to netcdf file + ! + ! !DESCRIPTION: + ! Write AV to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_avs(filename,gsmap,AVS,dname,whead,wdata,nx,ny,nt,fillval,pre,tavg,& + use_float,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(mct_gsMap), intent(in) :: gsmap + type(mct_aVect) ,intent(in) :: AVS(:) ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer(in),optional,intent(in) :: nx ! 2d grid size if available + integer(in),optional,intent(in) :: ny ! 2d grid size if available + integer(in),optional,intent(in) :: nt ! time sample + real(r8),optional,intent(in) :: fillval ! fill value + character(len=*),optional,intent(in) :: pre ! prefix to variable name + logical,optional,intent(in) :: tavg ! is this a tavg + logical,optional,intent(in) :: use_float ! write output as float rather than double + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: mpicom + integer(in) :: iam + integer(in) :: nf,ns,ng,ni + integer(in) :: i,j,k,n,k1,k2 + integer(in),target :: dimid2(2) + integer(in),target :: dimid3(3) + integer(in),target :: dimid4(4) + integer(in),pointer :: dimid(:) + type(var_desc_t) :: varid + type(io_desc_t) :: iodesc + integer(kind=Pio_Offset_Kind) :: frame + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + character(CL) :: name1 ! var name + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + character(CL) :: lpre ! local prefix + logical :: exists + logical :: lwhead, lwdata + logical :: luse_float + integer(in) :: lnx,lny + real(r8) :: lfillvalue + real(r8), allocatable :: data(:) + character(*),parameter :: subName = '(seq_io_write_avs) ' + integer :: lbnum + integer, pointer :: Dof(:) + integer, pointer :: Dofn(:) + integer :: lfile_ind + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lfillvalue = fillvalue + if (present(fillval)) then + lfillvalue = fillval + endif + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + luse_float = .false. + if (present(use_float)) luse_float = use_float + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + ni = size(AVS) + + ns = mct_aVect_lsize(AVS(1)) + ng = mct_gsmap_gsize(gsmap) + lnx = ng + lny = 1 + + nf = mct_aVect_nRattr(AVS(1)) + if (nf < 1) then + write(logunit,*) subname,' ERROR: nf = ',nf,trim(dname) + call shr_sys_abort(subname//'nf error') + endif + frame = -1 + if (present(nt)) then + frame = nt + endif + + if (present(nx)) then + if (nx /= 0) lnx = nx + endif + if (present(ny)) then + if (ny /= 0) lny = ny + endif + if (lnx*lny /= ng) then + if(iam==0) write(logunit,*) subname,' ERROR: grid2d size not consistent ',ng,lnx,lny,trim(dname) + call shr_sys_abort(subname//' ERROR: grid2d size not consistent ') + endif + + if (lwhead) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_nx',lnx,dimid2(1)) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_ny',lny,dimid2(2)) + + if (ni > 1) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_ni',ni,dimid3(3)) + if (present(nt)) then + dimid4(1:2) = dimid2 + dimid4(3) = dimid3(3) + rcode = pio_inq_dimid(cpl_io_file(lfile_ind),'time',dimid4(4)) + dimid => dimid4 + else + dimid3(1:2) = dimid2 + dimid => dimid3 + endif + else + if (present(nt)) then + dimid3(1:2) = dimid2 + rcode = pio_inq_dimid(cpl_io_file(lfile_ind),'time',dimid3(3)) + dimid => dimid3 + else + dimid => dimid2 + endif + endif + + do k = 1,nf + call mct_aVect_getRList(mstring,k,AVS(1)) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + call seq_flds_lookup(itemc,longname=lname,stdname=sname,units=cunit) + if (luse_float) then + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_REAL,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",real(lfillvalue,r4)) + else + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_DOUBLE,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",lfillvalue) + end if + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"internal_dname",trim(dname)) + if (present(tavg)) then + if (tavg) then + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"cell_methods","time: mean") + endif + endif +!-------tcraig + endif + enddo + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + end if + + if (lwdata) then + allocate(data(ns*ni)) + ! note: size of dof is ns + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + if (ni > 1) then + allocate(dofn(ns*ni)) + n = 0 + do k1 = 1,ni + dofn(n+1:n+ns) = (k1-1)*ng + dof(:) + n = n + ns + enddo + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny,ni/), dofn, iodesc) + deallocate(dofn) + else + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + endif + deallocate(dof) + + do k = 1,nf + call mct_aVect_getRList(mstring,k,AVS(1)) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(name1),varid) + call pio_setframe(cpl_io_file(lfile_ind),varid,frame) + n = 0 + do k1 = 1,ni + data(n+1:n+ns) = AVS(k1)%rAttr(k,:) + n = n + ns + enddo + call pio_write_darray(cpl_io_file(lfile_ind), varid, iodesc, data, rcode, fillval=lfillvalue) + call pio_setdebuglevel(0) +!-------tcraig + endif + enddo + + deallocate(data) + call pio_freedecomp(cpl_io_file(lfile_ind), iodesc) + + end if + end subroutine seq_io_write_avs + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_avs - write AVS to netcdf file + ! + ! !DESCRIPTION: + ! Write AV to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_avscomp(filename, comp, flow, dname, & + whead, wdata, nx, ny, nt, fillval, pre, tavg, use_float, file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*) ,intent(in) :: filename ! file + type(component_type) ,intent(in) :: comp(:) ! data to be written + character(len=3) ,intent(in) :: flow ! 'c2x' or 'x2c' + character(len=*) ,intent(in) :: dname ! name of data + logical ,optional,intent(in) :: whead ! write header + logical ,optional,intent(in) :: wdata ! write data + integer(in) ,optional,intent(in) :: nx ! 2d grid size if available + integer(in) ,optional,intent(in) :: ny ! 2d grid size if available + integer(in) ,optional,intent(in) :: nt ! time sample + real(r8) ,optional,intent(in) :: fillval ! fill value + character(len=*) ,optional,intent(in) :: pre ! prefix to variable name + logical ,optional,intent(in) :: tavg ! is this a tavg + logical ,optional,intent(in) :: use_float ! write output as float rather than double + integer ,optional,intent(in) :: file_ind + + !EOP + + type(mct_gsMap), pointer :: gsmap ! global seg map on coupler processes + type(mct_avect), pointer :: avcomp1 + type(mct_avect), pointer :: avcomp + integer(in) :: rcode + integer(in) :: mpicom + integer(in) :: iam + integer(in) :: nf,ns,ng,ni + integer(in) :: i,j,k,n,k1,k2 + integer(in),target :: dimid2(2) + integer(in),target :: dimid3(3) + integer(in),target :: dimid4(4) + integer(in),pointer :: dimid(:) + type(var_desc_t) :: varid + type(io_desc_t) :: iodesc + integer(kind=Pio_Offset_Kind) :: frame + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + character(CL) :: name1 ! var name + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + character(CL) :: lpre ! local prefix + logical :: exists + logical :: lwhead, lwdata + logical :: luse_float + integer(in) :: lnx,lny + real(r8) :: lfillvalue + real(r8), allocatable :: data(:) + character(*),parameter :: subName = '(seq_io_write_avs) ' + integer :: lbnum + integer, pointer :: Dof(:) + integer, pointer :: Dofn(:) + integer :: lfile_ind + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lfillvalue = fillvalue + if (present(fillval)) then + lfillvalue = fillval + endif + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + frame = -1 + if (present(nt)) then + frame = nt + endif + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + luse_float = .false. + if (present(use_float)) luse_float = use_float + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + ni = size(comp) + if (trim(flow) == 'x2c') avcomp1 => component_get_x2c_cx(comp(1)) + if (trim(flow) == 'c2x') avcomp1 => component_get_c2x_cx(comp(1)) + gsmap => component_get_gsmap_cx(comp(1)) + ns = mct_aVect_lsize(avcomp1) + ng = mct_gsmap_gsize(gsmap) + lnx = ng + lny = 1 + + nf = mct_aVect_nRattr(avcomp1) + if (nf < 1) then + write(logunit,*) subname,' ERROR: nf = ',nf,trim(dname) + call shr_sys_abort(subname//'nf error') + endif + + if (present(nx)) then + if (nx /= 0) lnx = nx + endif + if (present(ny)) then + if (ny /= 0) lny = ny + endif + if (lnx*lny /= ng) then + if(iam==0) then + write(logunit,*) subname,' ERROR: grid2d size not consistent ',& + ng,lnx,lny,trim(dname) + end if + call shr_sys_abort(subname//'ERROR: grid2d size not consistent ') + endif + + if (lwhead) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_nx',lnx,dimid2(1)) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_ny',lny,dimid2(2)) + + if (ni > 1) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(lpre)//'_ni',ni,dimid3(3)) + if (present(nt)) then + dimid4(1:2) = dimid2 + dimid4(3) = dimid3(3) + rcode = pio_inq_dimid(cpl_io_file(lfile_ind),'time',dimid4(4)) + dimid => dimid4 + else + dimid3(1:2) = dimid2 + dimid => dimid3 + endif + else + if (present(nt)) then + dimid3(1:2) = dimid2 + rcode = pio_inq_dimid(cpl_io_file(lfile_ind),'time',dimid3(3)) + dimid => dimid3 + else + dimid => dimid2 + endif + endif + + do k = 1,nf + call mct_aVect_getRList(mstring,k,avcomp1) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + call seq_flds_lookup(itemc,longname=lname,stdname=sname,units=cunit) + if (luse_float) then + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_REAL,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",real(lfillvalue,r4)) + else + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(name1),PIO_DOUBLE,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"_FillValue",lfillvalue) + end if + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"internal_dname",trim(dname)) + if (present(tavg)) then + if (tavg) then + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"cell_methods","time: mean") + endif + endif +!-------tcraig + endif + enddo + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + end if + + if (lwdata) then + allocate(data(ns*ni)) + ! note: size of dof is ns + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + if (ni > 1) then + allocate(dofn(ns*ni)) + n = 0 + do k1 = 1,ni + do k2 = 1,ns + n = n + 1 + dofn(n) = (k1-1)*ng + dof(k2) + enddo + enddo + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny,ni/), dofn, iodesc) + deallocate(dofn) + else + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + endif + deallocate(dof) + + do k = 1,nf + call mct_aVect_getRList(mstring,k,avcomp1) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) +!-------tcraig, this is a temporary mod to NOT write hgt + if (trim(itemc) /= "hgt") then + name1 = trim(lpre)//'_'//trim(itemc) + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(name1),varid) + call pio_setframe(cpl_io_file(lfile_ind),varid,frame) + n = 0 + do k1 = 1,ni + if (trim(flow) == 'x2c') avcomp => component_get_x2c_cx(comp(k1)) + if (trim(flow) == 'c2x') avcomp => component_get_c2x_cx(comp(k1)) + do k2 = 1,ns + n = n + 1 + data(n) = avcomp%rAttr(k,k2) + enddo + enddo + call pio_write_darray(cpl_io_file(lfile_ind), varid, iodesc, data, rcode, fillval=lfillvalue) +!-------tcraig + endif + enddo + + deallocate(data) + call pio_freedecomp(cpl_io_file(lfile_ind), iodesc) + + end if + end subroutine seq_io_write_avscomp + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_int - write scalar integer to netcdf file + ! + ! !DESCRIPTION: + ! Write scalar integer to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_int(filename,idata,dname,whead,wdata,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + integer(in) ,intent(in) :: idata ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: iam + type(var_desc_t) :: varid + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + logical :: exists + logical :: lwhead, lwdata + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_int) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + call seq_flds_lookup(trim(dname),longname=lname,stdname=sname,units=cunit) +! rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(dname)//'_nx',1,dimid(1)) +! rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_INT,dimid,varid) + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_INT,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + endif + + if (lwdata) then + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(dname),varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,idata) + + ! write(logunit,*) subname,' wrote AV ',trim(dname),lwhead,lwdata + endif + + end subroutine seq_io_write_int + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_int1d - write 1d integer array to netcdf file + ! + ! !DESCRIPTION: + ! Write 1d integer array to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_int1d(filename,idata,dname,whead,wdata,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + integer(in) ,intent(in) :: idata(:) ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: iam + integer(in) :: dimid(1) + type(var_desc_t) :: varid + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + integer(in) :: lnx + logical :: exists + logical :: lwhead, lwdata + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_int1d) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + call seq_flds_lookup(trim(dname),longname=lname,stdname=sname,units=cunit) + lnx = size(idata) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(dname)//'_nx',lnx,dimid(1)) + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_INT,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + endif + + if (lwdata) then + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(dname),varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,idata) + endif + + ! write(logunit,*) subname,' wrote AV ',trim(dname),lwhead,lwdata + + end subroutine seq_io_write_int1d + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_r8 - write scalar double to netcdf file + ! + ! !DESCRIPTION: + ! Write scalar double to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_r8(filename,rdata,dname,whead,wdata,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + real(r8) ,intent(in) :: rdata ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: iam + type(var_desc_t) :: varid + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + logical :: exists + logical :: lwhead, lwdata + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_r8) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + call seq_flds_lookup(trim(dname),longname=lname,stdname=sname,units=cunit) +! rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(dname)//'_nx',1,dimid(1)) +! rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_DOUBLE,dimid,varid) + + + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_DOUBLE,varid) + if(rcode==PIO_NOERR) then + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + end if + endif + + if (lwdata) then + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(dname),varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,rdata) + endif + + + end subroutine seq_io_write_r8 + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_r81d - write 1d double array to netcdf file + ! + ! !DESCRIPTION: + ! Write 1d double array to netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_r81d(filename,rdata,dname,whead,wdata,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + real(r8) ,intent(in) :: rdata(:) ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: mpicom + integer(in) :: iam + integer(in) :: dimid(1) + type(var_desc_t) :: varid + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + integer(in) :: lnx + logical :: exists + logical :: lwhead, lwdata + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_r81d) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + call seq_flds_lookup(trim(dname),longname=lname,stdname=sname,units=cunit) + lnx = size(rdata) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(dname)//'_nx',lnx,dimid(1)) + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_DOUBLE,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + endif + + if (lwdata) then + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(dname),varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,rdata) + + ! write(logunit,*) subname,' wrote AV ',trim(dname),lwhead,lwdata + endif + + end subroutine seq_io_write_r81d + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_write_char - write char string to netcdf file + ! + ! !DESCRIPTION: + ! Write char string to netcdf file + ! + ! !REVISION HISTORY: + ! 2010-July-06 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_write_char(filename,rdata,dname,whead,wdata,file_ind) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + character(len=*),intent(in) :: rdata ! data to be written + character(len=*),intent(in) :: dname ! name of data + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + integer,optional,intent(in) :: file_ind + + !EOP + + integer(in) :: rcode + integer(in) :: mpicom + integer(in) :: iam + integer(in) :: dimid(1) + type(var_desc_t) :: varid + character(CL) :: cunit ! var units + character(CL) :: lname ! long name + character(CL) :: sname ! standard name + integer(in) :: lnx + logical :: exists + logical :: lwhead, lwdata + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_char) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + call seq_flds_lookup(trim(dname),longname=lname,stdname=sname,units=cunit) + lnx = len(charvar) + rcode = pio_def_dim(cpl_io_file(lfile_ind),trim(dname)//'_len',lnx,dimid(1)) + rcode = pio_def_var(cpl_io_file(lfile_ind),trim(dname),PIO_CHAR,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"units",trim(cunit)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"long_name",trim(lname)) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,"standard_name",trim(sname)) + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + endif + + if (lwdata) then + charvar = '' + charvar = trim(rdata) + rcode = pio_inq_varid(cpl_io_file(lfile_ind),trim(dname),varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,charvar) + endif + + end subroutine seq_io_write_char + + !=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_io_write_time - write time variable to netcdf file +! +! !DESCRIPTION: +! Write time variable to netcdf file +! +! !REVISION HISTORY: +! 2009-Feb-11 - M. Vertenstein - initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_io_write_time(filename,time_units,time_cal,time_val,nt,whead,wdata,tbnds,file_ind) + + use shr_cal_mod, only : shr_cal_calMaxLen, shr_cal_calendarName, & + shr_cal_noleap, shr_cal_gregorian + +! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + character(len=*),intent(in) :: time_units ! units of time + character(len=*),intent(in) :: time_cal ! calendar type + real(r8) ,intent(in) :: time_val ! data to be written + integer(in),optional,intent(in) :: nt + logical,optional,intent(in) :: whead ! write header + logical,optional,intent(in) :: wdata ! write data + real(r8),optional,intent(in) :: tbnds(2) ! time bounds + integer,optional,intent(in) :: file_ind + +!EOP + + integer(in) :: rcode + integer(in) :: iam + integer(in) :: dimid(1) + integer(in) :: dimid2(2) + type(var_desc_t) :: varid + integer(in) :: lnx + logical :: exists + logical :: lwhead, lwdata + integer :: start(4),count(4) + character(len=shr_cal_calMaxLen) :: lcalendar + real(r8) :: time_val_1d(1) + integer :: lfile_ind + character(*),parameter :: subName = '(seq_io_write_time) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lwhead = .true. + lwdata = .true. + if (present(whead)) lwhead = whead + if (present(wdata)) lwdata = wdata + + if (.not.lwhead .and. .not.lwdata) then + ! should we write a warning? + return + endif + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + call seq_comm_setptrs(CPLID,iam=iam) + + if (lwhead) then + rcode = pio_def_dim(cpl_io_file(lfile_ind),'time',PIO_UNLIMITED,dimid(1)) + rcode = pio_def_var(cpl_io_file(lfile_ind),'time',PIO_DOUBLE,dimid,varid) + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,'units',trim(time_units)) + lcalendar = shr_cal_calendarName(time_cal,trap=.false.) + if (trim(lcalendar) == trim(shr_cal_noleap)) then + lcalendar = 'noleap' + elseif (trim(lcalendar) == trim(shr_cal_gregorian)) then + lcalendar = 'gregorian' + endif + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,'calendar',trim(lcalendar)) + if (present(tbnds)) then + rcode = pio_put_att(cpl_io_file(lfile_ind),varid,'bounds','time_bnds') + dimid2(2)=dimid(1) + rcode = pio_def_dim(cpl_io_file(lfile_ind),'ntb',2,dimid2(1)) + rcode = pio_def_var(cpl_io_file(lfile_ind),'time_bnds',PIO_DOUBLE,dimid2,varid) + endif + if (lwdata) call seq_io_enddef(filename, file_ind=lfile_ind) + endif + + if (lwdata) then + start = 1 + count = 1 + if (present(nt)) then + start(1) = nt + endif + time_val_1d(1) = time_val + rcode = pio_inq_varid(cpl_io_file(lfile_ind),'time',varid) + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,start,count,time_val_1d) + if (present(tbnds)) then + rcode = pio_inq_varid(cpl_io_file(lfile_ind),'time_bnds',varid) + start = 1 + count = 1 + if (present(nt)) then + start(2) = nt + endif + count(1) = 2 + rcode = pio_put_var(cpl_io_file(lfile_ind),varid,start,count,tbnds) + endif + + ! write(logunit,*) subname,' wrote time ',lwhead,lwdata + endif + + end subroutine seq_io_write_time + +!=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_av - read AV from netcdf file + ! + ! !DESCRIPTION: + ! Read AV from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_av(filename,gsmap,AV,dname,pre) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(mct_gsMap), intent(in) :: gsmap + type(mct_aVect) ,intent(inout):: AV ! data to be read + character(len=*),intent(in) :: dname ! name of data + character(len=*),intent(in),optional :: pre ! prefix name + + !EOP + + integer(in) :: rcode + integer(in) :: iam,mpicom + integer(in) :: nf,ns,ng + integer(in) :: i,j,k,n, ndims + type(file_desc_t) :: pioid + integer(in) :: dimid(2) + type(var_desc_t) :: varid + integer(in) :: lnx,lny + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + logical :: exists + type(io_desc_t) :: iodesc + integer(in), pointer :: dof(:) + character(CL) :: lversion + character(CL) :: name1 + character(CL) :: lpre + character(*),parameter :: subName = '(seq_io_read_av) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lversion = trim(version0) + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + + ns = mct_aVect_lsize(AV) + nf = mct_aVect_nRattr(AV) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_av exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + if(iam==0) write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + do k = 1,nf + call mct_aVect_getRList(mstring,k,AV) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + if (trim(lversion) == trim(version)) then + name1 = trim(lpre)//'_'//trim(itemc) + else + name1 = trim(prefix)//trim(dname)//'_'//trim(itemc) + endif + call pio_seterrorhandling(pioid, PIO_BCAST_ERROR) + rcode = pio_inq_varid(pioid,trim(name1),varid) + if (rcode == pio_noerr) then + if (k==1) then + rcode = pio_inq_varndims(pioid, varid, ndims) + rcode = pio_inq_vardimid(pioid, varid, dimid(1:ndims)) + rcode = pio_inq_dimlen(pioid, dimid(1), lnx) + if (ndims>=2) then + rcode = pio_inq_dimlen(pioid, dimid(2), lny) + else + lny = 1 + end if + ng = lnx * lny + if (ng /= mct_gsmap_gsize(gsmap)) then + if (iam==0) write(logunit,*) subname,' ERROR: dimensions do not match',& + lnx,lny,mct_gsmap_gsize(gsmap) + call shr_sys_abort(subname//'ERROR: dimensions do not match') + end if + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + deallocate(dof) + end if + call pio_read_darray(pioid,varid,iodesc, av%rattr(k,:), rcode) + else + write(logunit,*)'seq_io_readav warning: field ',trim(itemc),' is not on restart file' + write(logunit,*)'for backwards compatibility will set it to 0' + av%rattr(k,:) = 0.0_r8 + end if + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + + enddo + + !--- zero out fill value, this is somewhat arbitrary + do n = 1,ns + do k = 1,nf + if (AV%rAttr(k,n) == fillvalue) then + AV%rAttr(k,n) = 0.0_r8 + endif + enddo + enddo + + call pio_freedecomp(pioid, iodesc) + call pio_closefile(pioid) + + end subroutine seq_io_read_av + +!=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_avs - read AV from netcdf file + ! + ! !DESCRIPTION: + ! Read AV from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_avs(filename,gsmap,AVS,dname,pre) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(mct_gsMap), intent(in) :: gsmap + type(mct_aVect) ,intent(inout):: AVS(:) ! data to be read + character(len=*),intent(in) :: dname ! name of data + character(len=*),intent(in),optional :: pre ! prefix name + + !EOP + + integer(in) :: rcode + integer(in) :: iam,mpicom + integer(in) :: nf,ns,ng,ni + integer(in) :: i,j,k,n,n1,n2,ndims + type(file_desc_t) :: pioid + integer(in) :: dimid(4) + type(var_desc_t) :: varid + integer(in) :: lnx,lny,lni + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + logical :: exists + type(io_desc_t) :: iodesc + integer(in), pointer :: dof(:) + integer(in), pointer :: dofn(:) + real(r8), allocatable :: data(:) + character(CL) :: lversion + character(CL) :: name1 + character(CL) :: lpre + character(*),parameter :: subName = '(seq_io_read_avs) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lversion = trim(version0) + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + + ni = size(AVS) + ns = mct_aVect_lsize(AVS(1)) + nf = mct_aVect_nRattr(AVS(1)) + ng = mct_gsmap_gsize(gsmap) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_avs exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + if(iam==0) write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + allocate(data(ni*ns)) + + do k = 1,nf + call mct_aVect_getRList(mstring,k,AVS(1)) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + if (trim(lversion) == trim(version)) then + name1 = trim(lpre)//'_'//trim(itemc) + else + name1 = trim(prefix)//trim(dname)//'_'//trim(itemc) + endif + call pio_seterrorhandling(pioid, PIO_BCAST_ERROR) + rcode = pio_inq_varid(pioid,trim(name1),varid) + if (rcode == pio_noerr) then + if (k==1) then + rcode = pio_inq_varndims(pioid, varid, ndims) + rcode = pio_inq_vardimid(pioid, varid, dimid(1:ndims)) + rcode = pio_inq_dimlen(pioid, dimid(1), lnx) + if (ndims>=2) then + rcode = pio_inq_dimlen(pioid, dimid(2), lny) + else + lny = 1 + end if + if (lnx*lny /= ng) then + write(logunit,*) subname,' ERROR: dimensions do not match',& + lnx,lny,mct_gsmap_gsize(gsmap) + call shr_sys_abort(subname//'ERROR: dimensions do not match') + end if + if (ndims>=3) then + rcode = pio_inq_dimlen(pioid, dimid(3), lni) + else + lni = 1 + end if + if (ni /= lni) then + write(logunit,*) subname,' ERROR: ni dimensions do not match',ni,lni + call shr_sys_abort(subname//'ERROR: ni dimensions do not match') + end if + if (ni > 1) then + allocate(dofn(ns*ni)) + n = 0 + do n1 = 1,ni + do n2 = 1,ns + n = n + 1 + dofn(n) = (n1-1)*ng + dof(n2) + enddo + enddo + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny,lni/), dofn, iodesc) + deallocate(dofn) + else + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + endif + deallocate(dof) + end if + + call pio_read_darray(pioid,varid,iodesc, data, rcode) + n = 0 + do n1 = 1,ni + do n2 = 1,ns + n = n + 1 + avs(n1)%rAttr(k,n2) = data(n) + enddo + enddo + else + write(logunit,*)'seq_io_readav warning: field ',trim(itemc),' is not on restart file' + write(logunit,*)'for backwards compatibility will set it to 0' + do n1 = 1,ni + avs(n1)%rattr(k,:) = 0.0_r8 + enddo + end if + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + enddo + + deallocate(data) + + !--- zero out fill value, this is somewhat arbitrary + do n1 = 1,ni + do n2 = 1,ns + do k = 1,nf + if (AVS(n1)%rAttr(k,n2) == fillvalue) then + AVS(n1)%rAttr(k,n2) = 0.0_r8 + endif + enddo + enddo + enddo + + call pio_freedecomp(pioid, iodesc) + call pio_closefile(pioid) + + end subroutine seq_io_read_avs + +!=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_avs - read AV from netcdf file + ! + ! !DESCRIPTION: + ! Read AV from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_avscomp(filename, comp, flow, dname, pre) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*), intent(in) :: filename ! file + type(component_type), intent(inout) :: comp(:) + character(len=3), intent(in) :: flow ! 'c2x' or 'x2c' + character(len=*), intent(in) :: dname ! name of data + character(len=*), intent(in),optional :: pre ! prefix name + + !EOP + + type(mct_gsMap), pointer :: gsmap + type(mct_aVect), pointer :: avcomp + type(mct_aVect), pointer :: avcomp1 + integer(in) :: rcode + integer(in) :: iam,mpicom + integer(in) :: nf,ns,ng,ni + integer(in) :: i,j,k,n,n1,n2,ndims + type(file_desc_t) :: pioid + integer(in) :: dimid(4) + type(var_desc_t) :: varid + integer(in) :: lnx,lny,lni + type(mct_string) :: mstring ! mct char type + character(CL) :: itemc ! string converted to char + logical :: exists + type(io_desc_t) :: iodesc + integer(in), pointer :: dof(:) + integer(in), pointer :: dofn(:) + real(r8), allocatable :: data(:) + character(CL) :: lversion + character(CL) :: name1 + character(CL) :: lpre + character(*),parameter :: subName = '(seq_io_read_avs) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + lversion = trim(version0) + + lpre = trim(dname) + if (present(pre)) then + lpre = trim(pre) + endif + + gsmap => component_get_gsmap_cx(comp(1)) + if (trim(flow) == 'x2c') avcomp1 => component_get_x2c_cx(comp(1)) + if (trim(flow) == 'c2x') avcomp1 => component_get_c2x_cx(comp(1)) + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + call mct_gsmap_OrderedPoints(gsmap, iam, Dof) + + ni = size(comp) + ns = mct_aVect_lsize(avcomp1) + nf = mct_aVect_nRattr(avcomp1) + ng = mct_gsmap_gsize(gsmap) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_avs exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + if(iam==0) write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + allocate(data(ni*ns)) + + do k = 1,nf + call mct_aVect_getRList(mstring,k,avcomp1) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + if (trim(lversion) == trim(version)) then + name1 = trim(lpre)//'_'//trim(itemc) + else + name1 = trim(prefix)//trim(dname)//'_'//trim(itemc) + endif + call pio_seterrorhandling(pioid, PIO_BCAST_ERROR) + rcode = pio_inq_varid(pioid,trim(name1),varid) + if (rcode == pio_noerr) then + if (k==1) then + rcode = pio_inq_varndims(pioid, varid, ndims) + rcode = pio_inq_vardimid(pioid, varid, dimid(1:ndims)) + rcode = pio_inq_dimlen(pioid, dimid(1), lnx) + if (ndims>=2) then + rcode = pio_inq_dimlen(pioid, dimid(2), lny) + else + lny = 1 + end if + if (lnx*lny /= ng) then + write(logunit,*) subname,' ERROR: dimensions do not match',& + lnx,lny,mct_gsmap_gsize(gsmap) + call shr_sys_abort(subname//'ERROR: dimensions do not match') + end if + if (ndims>=3) then + rcode = pio_inq_dimlen(pioid, dimid(3), lni) + else + lni = 1 + end if + if (ni /= lni) then + write(logunit,*) subname,' ERROR: ni dimensions do not match',ni,lni + call shr_sys_abort(subname//'ERROR: ni dimensions do not match') + end if + if (ni > 1) then + allocate(dofn(ns*ni)) + n = 0 + do n1 = 1,ni + do n2 = 1,ns + n = n + 1 + dofn(n) = (n1-1)*ng + dof(n2) + enddo + enddo + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny,lni/), dofn, iodesc) + deallocate(dofn) + else + call pio_initdecomp(cpl_io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + endif + deallocate(dof) + end if + + call pio_read_darray(pioid,varid,iodesc, data, rcode) + n = 0 + do n1 = 1,ni + if (trim(flow) == 'x2c') avcomp => component_get_x2c_cx(comp(n1)) + if (trim(flow) == 'c2x') avcomp => component_get_c2x_cx(comp(n1)) + do n2 = 1,ns + n = n + 1 + avcomp%rAttr(k,n2) = data(n) + enddo + enddo + else + write(logunit,*)'seq_io_readav warning: field ',trim(itemc),' is not on restart file' + write(logunit,*)'for backwards compatibility will set it to 0' + do n1 = 1,ni + if (trim(flow) == 'x2c') avcomp => component_get_x2c_cx(comp(n1)) + if (trim(flow) == 'c2x') avcomp => component_get_c2x_cx(comp(n1)) + avcomp%rattr(k,:) = 0.0_r8 + enddo + end if + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + enddo + + deallocate(data) + + !--- zero out fill value, this is somewhat arbitrary + do n1 = 1,ni + if (trim(flow) == 'x2c') avcomp => component_get_x2c_cx(comp(n1)) + if (trim(flow) == 'c2x') avcomp => component_get_c2x_cx(comp(n1)) + do n2 = 1,ns + do k = 1,nf + if (avcomp%rAttr(k,n2) == fillvalue) then + avcomp%rAttr(k,n2) = 0.0_r8 + endif + enddo + enddo + enddo + + call pio_freedecomp(pioid, iodesc) + call pio_closefile(pioid) + + end subroutine seq_io_read_avscomp + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_int - read scalar integer from netcdf file + ! + ! !DESCRIPTION: + ! Read scalar integer from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_int(filename,idata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + integer ,intent(inout):: idata ! integer data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer :: i1d(1) + character(*),parameter :: subName = '(seq_io_read_int) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_io_read_int1d(filename,i1d,dname) + idata = i1d(1) + + end subroutine seq_io_read_int + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_int1d - read 1d integer from netcdf file + ! + ! !DESCRIPTION: + ! Read 1d integer array from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_int1d(filename,idata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + integer(in) ,intent(inout):: idata(:) ! integer data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer(in) :: rcode + integer(in) :: iam,mpicom + type(file_desc_t) :: pioid + type(var_desc_t) :: varid + logical :: exists + character(CL) :: lversion + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_int1d) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + lversion=trim(version0) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_int1d exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + ! write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + if (trim(lversion) == trim(version)) then + name1 = trim(dname) + else + name1 = trim(prefix)//trim(dname) + endif + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,idata) + + call pio_closefile(pioid) + + ! write(logunit,*) subname,' read int ',trim(dname) + + + end subroutine seq_io_read_int1d + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_r8 - read scalar double from netcdf file + ! + ! !DESCRIPTION: + ! Read scalar double from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_r8(filename,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + real(r8) ,intent(inout):: rdata ! real data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + real(r8) :: r1d(1) + character(*),parameter :: subName = '(seq_io_read_r8) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_io_read_r81d(filename,r1d,dname) + rdata = r1d(1) + + end subroutine seq_io_read_r8 + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_r81d - read 1d double array from netcdf file + ! + ! !DESCRIPTION: + ! Read 1d double array from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_r81d(filename,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + real(r8) ,intent(inout):: rdata(:) ! real data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer(in) :: rcode + integer(in) :: iam,mpicom + type(file_desc_T) :: pioid + type(var_desc_t) :: varid + logical :: exists + character(CL) :: lversion + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_r81d) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + + lversion=trim(version0) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_r81d exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + ! write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + if (trim(lversion) == trim(version)) then + name1 = trim(dname) + else + name1 = trim(prefix)//trim(dname) + endif + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,rdata) + + call pio_closefile(pioid) + + ! write(logunit,*) subname,' read int ',trim(dname) + + end subroutine seq_io_read_r81d + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_char - read char string from netcdf file + ! + ! !DESCRIPTION: + ! Read char string from netcdf file + ! + ! !REVISION HISTORY: + ! 2010-July-06 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_char(filename,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + character(len=*),intent(inout):: rdata ! character data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer(in) :: rcode + integer(in) :: iam,mpicom + type(file_desc_T) :: pioid + type(var_desc_t) :: varid + logical :: exists + character(CL) :: lversion + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_char) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + + lversion=trim(version0) + + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_char exists') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + ! write(logunit,*) subname,' open file ',trim(filename) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename),' ',trim(dname) + call shr_sys_abort(subname//'ERROR: file invalid '//trim(filename)//' '//trim(dname)) + endif + + if (trim(lversion) == trim(version)) then + name1 = trim(dname) + else + name1 = trim(prefix)//trim(dname) + endif + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,charvar) + rdata = trim(charvar) + + call pio_closefile(pioid) + + end subroutine seq_io_read_char + + !=============================================================================== +!=============================================================================== +end module seq_io_mod diff --git a/driver-mct/main/seq_map_mod.F90 b/driver-mct/main/seq_map_mod.F90 new file mode 100644 index 000000000000..19050115e21d --- /dev/null +++ b/driver-mct/main/seq_map_mod.F90 @@ -0,0 +1,908 @@ +module seq_map_mod + +!--------------------------------------------------------------------- +! +! Purpose: +! +! General mapping routines +! including self normalizing mapping routine with optional fraction +! +! Author: T. Craig, Jan-28-2011 +! +!--------------------------------------------------------------------- + + use shr_kind_mod ,only: R8 => SHR_KIND_R8, IN=>SHR_KIND_IN + use shr_kind_mod ,only: CL => SHR_KIND_CL, CX => SHR_KIND_CX + use shr_sys_mod + use shr_const_mod + use shr_mct_mod, only: shr_mct_sMatPInitnc, shr_mct_queryConfigFile + use mct_mod + use seq_comm_mct + use component_type_mod + use seq_map_type_mod + + implicit none + save + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: seq_map_init_rcfile ! cpl pes + public :: seq_map_init_rearrolap ! cpl pes + public :: seq_map_initvect ! cpl pes + public :: seq_map_map ! cpl pes + public :: seq_map_mapvect ! cpl pes + public :: seq_map_readdata ! cpl pes + + interface seq_map_avNorm + module procedure seq_map_avNormArr + module procedure seq_map_avNormAvF + end interface + +!-------------------------------------------------------------------------- +! Public data +!-------------------------------------------------------------------------- + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + character(*),parameter :: seq_map_stroff = 'variable_unset' + character(*),parameter :: seq_map_stron = 'StrinG_is_ON' + real(R8),parameter,private :: deg2rad = shr_const_pi/180.0_R8 ! deg to rads + +!======================================================================= +contains +!======================================================================= + + subroutine seq_map_init_rcfile( mapper, comp_s, comp_d, & + maprcfile, maprcname, maprctype, samegrid, string, esmf_map) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout),pointer :: mapper + type(component_type) ,intent(inout) :: comp_s + type(component_type) ,intent(inout) :: comp_d + character(len=*) ,intent(in) :: maprcfile + character(len=*) ,intent(in) :: maprcname + character(len=*) ,intent(in) :: maprctype + logical ,intent(in) :: samegrid + character(len=*) ,intent(in),optional :: string + logical ,intent(in),optional :: esmf_map + ! + ! Local Variables + ! + type(mct_gsmap), pointer :: gsmap_s ! temporary pointers + type(mct_gsmap), pointer :: gsmap_d ! temporary pointers + integer(IN) :: mpicom + character(CX) :: mapfile + character(CL) :: maptype + integer(IN) :: mapid + integer(IN) :: ssize,dsize + character(len=*),parameter :: subname = "(seq_map_init_rcfile) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + endif + + call seq_comm_setptrs(CPLID, mpicom=mpicom) + + gsmap_s => component_get_gsmap_cx(comp_s) + gsmap_d => component_get_gsmap_cx(comp_d) + + if (mct_gsmap_Identical(gsmap_s,gsmap_d)) then + call seq_map_mapmatch(mapid,gsmap_s=gsmap_s,gsmap_d=gsmap_d,strategy="copy") + + if (mapid > 0) then + call seq_map_mappoint(mapid,mapper) + else + call seq_map_mapinit(mapper,mpicom) + mapper%copy_only = .true. + mapper%strategy = "copy" + mapper%gsmap_s => component_get_gsmap_cx(comp_s) + mapper%gsmap_d => component_get_gsmap_cx(comp_d) + endif + + elseif (samegrid) then + call seq_map_mapmatch(mapid,gsmap_s=gsmap_s,gsmap_d=gsmap_d,strategy="rearrange") + + if (mapid > 0) then + call seq_map_mappoint(mapid,mapper) + else + ! --- Initialize rearranger + call seq_map_mapinit(mapper,mpicom) + mapper%rearrange_only = .true. + mapper%strategy = "rearrange" + mapper%gsmap_s => component_get_gsmap_cx(comp_s) + mapper%gsmap_d => component_get_gsmap_cx(comp_d) + call seq_map_gsmapcheck(gsmap_s, gsmap_d) + call mct_rearr_init(gsmap_s, gsmap_d, mpicom, mapper%rearr) + endif + + else + + ! --- Initialize Smatp + call shr_mct_queryConfigFile(mpicom,maprcfile,maprcname,mapfile,maprctype,maptype) + + call seq_map_mapmatch(mapid,gsMap_s=gsMap_s,gsMap_d=gsMap_d,mapfile=mapfile,strategy=maptype) + + if (mapid > 0) then + call seq_map_mappoint(mapid,mapper) + else + call seq_map_mapinit(mapper,mpicom) + mapper%mapfile = trim(mapfile) + mapper%strategy= trim(maptype) + mapper%gsmap_s => component_get_gsmap_cx(comp_s) + mapper%gsmap_d => component_get_gsmap_cx(comp_d) + + call shr_mct_sMatPInitnc(mapper%sMatp, mapper%gsMap_s, mapper%gsMap_d, trim(mapfile),trim(maptype),mpicom) + if (present(esmf_map)) mapper%esmf_map = esmf_map + + if (mapper%esmf_map) then + call shr_sys_abort(subname//' ERROR: esmf SMM not supported') + endif ! esmf_map + + endif ! mapid >= 0 + endif + + if (seq_comm_iamroot(CPLID)) then + write(logunit,'(2A,I6,4A)') subname,' mapper counter, strategy, mapfile = ', & + mapper%counter,' ',trim(mapper%strategy),' ',trim(mapper%mapfile) + call shr_sys_flush(logunit) + endif + + end subroutine seq_map_init_rcfile + + !======================================================================= + + subroutine seq_map_init_rearrolap(mapper, comp_s, comp_d, string) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout),pointer :: mapper + type(component_type) ,intent(inout) :: comp_s + type(component_type) ,intent(inout) :: comp_d + character(len=*) ,intent(in),optional :: string + ! + ! Local Variables + ! + integer(IN) :: mapid + type(mct_gsmap), pointer :: gsmap_s + type(mct_gsmap), pointer :: gsmap_d + integer(IN) :: mpicom + character(len=*),parameter :: subname = "(seq_map_init_rearrolap) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + endif + + call seq_comm_setptrs(CPLID, mpicom=mpicom) + + gsmap_s => component_get_gsmap_cx(comp_s) + gsmap_d => component_get_gsmap_cx(comp_d) + + if (mct_gsmap_Identical(gsmap_s,gsmap_d)) then + call seq_map_mapmatch(mapid,gsmap_s=gsmap_s,gsmap_d=gsmap_d,strategy="copy") + + if (mapid > 0) then + call seq_map_mappoint(mapid,mapper) + else + call seq_map_mapinit(mapper,mpicom) + mapper%copy_only = .true. + mapper%strategy = "copy" + mapper%gsmap_s => component_get_gsmap_cx(comp_s) + mapper%gsmap_d => component_get_gsmap_cx(comp_d) + endif + + else + call seq_map_mapmatch(mapid,gsmap_s=gsmap_s,gsmap_d=gsmap_d,strategy="rearrange") + + if (mapid > 0) then + call seq_map_mappoint(mapid,mapper) + else + ! --- Initialize rearranger + call seq_map_mapinit(mapper, mpicom) + mapper%rearrange_only = .true. + mapper%strategy = "rearrange" + mapper%gsmap_s => component_get_gsmap_cx(comp_s) + mapper%gsmap_d => component_get_gsmap_cx(comp_d) + call seq_map_gsmapcheck(gsmap_s, gsmap_d) + call mct_rearr_init(gsmap_s, gsmap_d, mpicom, mapper%rearr) + endif + + endif + + if (seq_comm_iamroot(CPLID)) then + write(logunit,'(2A,I6,4A)') subname,' mapper counter, strategy, mapfile = ', & + mapper%counter,' ',trim(mapper%strategy),' ',trim(mapper%mapfile) + call shr_sys_flush(logunit) + endif + + end subroutine seq_map_init_rearrolap + + !======================================================================= + + subroutine seq_map_map( mapper, av_s, av_d, fldlist, norm, avwts_s, avwtsfld_s, & + string, msgtag ) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout) :: mapper + type(mct_aVect) ,intent(in) :: av_s + type(mct_aVect) ,intent(inout) :: av_d + character(len=*),intent(in),optional :: fldlist + logical ,intent(in),optional :: norm + type(mct_aVect) ,intent(in),optional :: avwts_s + character(len=*),intent(in),optional :: avwtsfld_s + character(len=*),intent(in),optional :: string + integer(IN) ,intent(in),optional :: msgtag + ! + ! Local Variables + ! + logical :: lnorm + integer(IN),save :: ltag ! message tag for rearrange + character(len=*),parameter :: subname = "(seq_map_map) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + endif + + lnorm = .true. + if (present(norm)) then + lnorm = norm + endif + + if (present(msgtag)) then + ltag = msgtag + else + ltag = 2000 + endif + + if (present(avwts_s) .and. .not. present(avwtsfld_s)) then + write(logunit,*) subname,' ERROR: avwts_s present but avwtsfld_s not' + call shr_sys_abort(subname//' ERROR: avwts present') + endif + if (.not. present(avwts_s) .and. present(avwtsfld_s)) then + write(logunit,*) subname,' ERROR: avwtsfld_s present but avwts_s not' + call shr_sys_abort(subname//' ERROR: avwtsfld present') + endif + + if (mapper%copy_only) then + !------------------------------------------- + ! COPY data + !------------------------------------------- + if (present(fldlist)) then + call mct_aVect_copy(aVin=av_s,aVout=av_d,rList=fldlist,vector=mct_usevector) + else + call mct_aVect_copy(aVin=av_s,aVout=av_d,vector=mct_usevector) + endif + + else if (mapper%rearrange_only) then + !------------------------------------------- + ! REARRANGE data + !------------------------------------------- + if (present(fldlist)) then + call mct_rearr_rearrange_fldlist(av_s, av_d, mapper%rearr, tag=ltag, VECTOR=mct_usevector, & + ALLTOALL=mct_usealltoall, fldlist=fldlist) + else + call mct_rearr_rearrange(av_s, av_d, mapper%rearr, tag=ltag, VECTOR=mct_usevector, & + ALLTOALL=mct_usealltoall) + endif + + else + !------------------------------------------- + ! MAP data + !------------------------------------------- + if (present(avwts_s)) then + if (present(fldlist)) then + call seq_map_avNorm(mapper, av_s, av_d, avwts_s, trim(avwtsfld_s), & + rList=fldlist, norm=lnorm) + else + call seq_map_avNorm(mapper, av_s, av_d, avwts_s, trim(avwtsfld_s), & + norm=lnorm) + endif + else + if (present(fldlist)) then + call seq_map_avNorm(mapper, av_s, av_d, rList=fldlist, norm=lnorm) + else + call seq_map_avNorm(mapper, av_s, av_d, norm=lnorm) + endif + endif + end if + + end subroutine seq_map_map + + !======================================================================= + + subroutine seq_map_initvect(mapper, type, comp_s, comp_d, string) + + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout) :: mapper + character(len=*) ,intent(in) :: type + type(component_type) ,intent(inout) :: comp_s + type(component_type) ,intent(inout) :: comp_d + character(len=*) ,intent(in),optional :: string + ! + ! Local Variables + ! + type(mct_gGrid), pointer :: dom_s + type(mct_gGrid), pointer :: dom_d + integer(IN) :: klon, klat, lsize, n + logical :: lnorm + character(len=CL) :: lstring + character(len=*),parameter :: subname = "(seq_map_initvect) " + !----------------------------------------------------- + + lstring = ' ' + if (present(string)) then + if (seq_comm_iamroot(CPLID)) write(logunit,'(A)') subname//' called for '//trim(string) + lstring = trim(string) + endif + + dom_s => component_get_dom_cx(comp_s) + dom_d => component_get_dom_cx(comp_d) + + if (trim(type(1:6)) == 'cart3d') then + if (mapper%cart3d_init == trim(seq_map_stron)) return + + !--- compute these up front for vector mapping --- + lsize = mct_aVect_lsize(dom_s%data) + allocate(mapper%slon_s(lsize),mapper%clon_s(lsize), & + mapper%slat_s(lsize),mapper%clat_s(lsize)) + klon = mct_aVect_indexRa(dom_s%data, "lon" ) + klat = mct_aVect_indexRa(dom_s%data, "lat" ) + do n = 1,lsize + mapper%slon_s(n) = sin(dom_s%data%rAttr(klon,n)*deg2rad) + mapper%clon_s(n) = cos(dom_s%data%rAttr(klon,n)*deg2rad) + mapper%slat_s(n) = sin(dom_s%data%rAttr(klat,n)*deg2rad) + mapper%clat_s(n) = cos(dom_s%data%rAttr(klat,n)*deg2rad) + enddo + + lsize = mct_aVect_lsize(dom_d%data) + allocate(mapper%slon_d(lsize),mapper%clon_d(lsize), & + mapper%slat_d(lsize),mapper%clat_d(lsize)) + klon = mct_aVect_indexRa(dom_d%data, "lon" ) + klat = mct_aVect_indexRa(dom_d%data, "lat" ) + do n = 1,lsize + mapper%slon_d(n) = sin(dom_d%data%rAttr(klon,n)*deg2rad) + mapper%clon_d(n) = cos(dom_d%data%rAttr(klon,n)*deg2rad) + mapper%slat_d(n) = sin(dom_d%data%rAttr(klat,n)*deg2rad) + mapper%clat_d(n) = cos(dom_d%data%rAttr(klat,n)*deg2rad) + enddo + mapper%cart3d_init = trim(seq_map_stron) + endif + + end subroutine seq_map_initvect + + !======================================================================= + + subroutine seq_map_mapvect( mapper, type, av_s, av_d, fldu, fldv, norm, string ) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout) :: mapper + character(len=*),intent(in) :: type + type(mct_aVect) ,intent(in) :: av_s + type(mct_aVect) ,intent(inout) :: av_d + character(len=*),intent(in) :: fldu + character(len=*),intent(in) :: fldv + logical ,intent(in),optional :: norm + character(len=*),intent(in),optional :: string + ! + ! Local Variables + ! + logical :: lnorm + character(len=CL) :: lstring + character(len=*),parameter :: subname = "(seq_map_mapvect) " + !----------------------------------------------------- + + lstring = ' ' + if (present(string)) then + if (seq_comm_iamroot(CPLID)) write(logunit,'(A)') subname//' called for '//trim(string) + lstring = trim(string) + endif + + if (mapper%copy_only .or. mapper%rearrange_only) then + return + endif + + lnorm = .true. + if (present(norm)) then + lnorm = norm + endif + + if (trim(type(1:6)) == 'cart3d') then + if (mapper%cart3d_init /= trim(seq_map_stron)) then + call shr_sys_abort(trim(subname)//' ERROR: cart3d not initialized '//trim(lstring)) + endif + call seq_map_cart3d(mapper, type, av_s, av_d, fldu, fldv, norm=lnorm, string=string) + elseif (trim(type) == 'none') then + call seq_map_map(mapper, av_s, av_d, fldlist=trim(fldu)//':'//trim(fldv), norm=lnorm) + else + write(logunit,*) subname,' ERROR: type unsupported ',trim(type) + call shr_sys_abort(trim(subname)//' ERROR in type='//trim(type)) + end if + + end subroutine seq_map_mapvect + + !======================================================================= + + subroutine seq_map_cart3d( mapper, type, av_s, av_d, fldu, fldv, norm, string) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) ,intent(inout) :: mapper + character(len=*),intent(in) :: type + type(mct_aVect) ,intent(in) :: av_s + type(mct_aVect) ,intent(inout) :: av_d + character(len=*),intent(in) :: fldu + character(len=*),intent(in) :: fldv + logical ,intent(in),optional :: norm + character(len=*),intent(in),optional :: string + ! + ! Local Variables + ! + integer :: lsize + logical :: lnorm + integer :: ku,kv,kux,kuy,kuz,n + real(r8) :: ue,un,ur,ux,uy,uz,speed + real(r8) :: urmaxl,urmax,uravgl,uravg,spavgl,spavg + type(mct_aVect) :: av3_s, av3_d + integer(in) :: mpicom,my_task,ierr,urcnt,urcntl + character(len=*),parameter :: subname = "(seq_map_cart3d) " + + lnorm = .true. + if (present(norm)) then + lnorm=norm + endif + + mpicom = mapper%mpicom + + ku = mct_aVect_indexRA(av_s, trim(fldu), perrwith='quiet') + kv = mct_aVect_indexRA(av_s, trim(fldv), perrwith='quiet') + + if (ku /= 0 .and. kv /= 0) then + lsize = mct_aVect_lsize(av_s) + call mct_avect_init(av3_s,rList='ux:uy:uz',lsize=lsize) + + lsize = mct_aVect_lsize(av_d) + call mct_avect_init(av3_d,rList='ux:uy:uz',lsize=lsize) + + kux = mct_aVect_indexRA(av3_s,'ux') + kuy = mct_aVect_indexRA(av3_s,'uy') + kuz = mct_aVect_indexRA(av3_s,'uz') + lsize = mct_aVect_lsize(av_s) + do n = 1,lsize + ur = 0.0_r8 + ue = av_s%rAttr(ku,n) + un = av_s%rAttr(kv,n) + ux = mapper%clon_s(n)*mapper%clat_s(n)*ur - & + mapper%clon_s(n)*mapper%slat_s(n)*un - & + mapper%slon_s(n)*ue + uy = mapper%slon_s(n)*mapper%clon_s(n)*ur - & + mapper%slon_s(n)*mapper%slat_s(n)*un + & + mapper%clon_s(n)*ue + uz = mapper%slat_s(n)*ur + & + mapper%clat_s(n)*un + av3_s%rAttr(kux,n) = ux + av3_s%rAttr(kuy,n) = uy + av3_s%rAttr(kuz,n) = uz + enddo + + call seq_map_map(mapper, av3_s, av3_d, norm=lnorm) + + kux = mct_aVect_indexRA(av3_d,'ux') + kuy = mct_aVect_indexRA(av3_d,'uy') + kuz = mct_aVect_indexRA(av3_d,'uz') + lsize = mct_aVect_lsize(av_d) + urmaxl = -1.0_r8 + uravgl = 0.0_r8 + urcntl = 0 + spavgl = 0.0_r8 + do n = 1,lsize + ux = av3_d%rAttr(kux,n) + uy = av3_d%rAttr(kuy,n) + uz = av3_d%rAttr(kuz,n) + ue = -mapper%slon_d(n) *ux + & + mapper%clon_d(n) *uy + un = -mapper%clon_d(n)*mapper%slat_d(n)*ux - & + mapper%slon_d(n)*mapper%slat_d(n)*uy + & + mapper%clat_d(n)*uz + ur = mapper%clon_d(n)*mapper%clat_d(n)*ux + & + mapper%slon_d(n)*mapper%clat_d(n)*uy - & + mapper%slat_d(n)*uz + speed = sqrt(ur*ur + ue*ue + un*un) + if (trim(type) == 'cart3d_diag' .or. trim(type) == 'cart3d_uvw_diag') then + if (speed /= 0.0_r8) then + urmaxl = max(urmaxl,abs(ur)) + uravgl = uravgl + abs(ur) + spavgl = spavgl + speed + urcntl = urcntl + 1 + endif + endif + if (type(1:10) == 'cart3d_uvw') then + !--- this adds ur to ue and un, while preserving u/v angle and total speed --- + if (un == 0.0_R8) then + !--- if ue is also 0.0 then just give speed to ue, this is arbitrary --- + av_d%rAttr(ku,n) = sign(speed,ue) + av_d%rAttr(kv,n) = 0.0_r8 + else if (ue == 0.0_R8) then + av_d%rAttr(ku,n) = 0.0_r8 + av_d%rAttr(kv,n) = sign(speed,un) + else + av_d%rAttr(ku,n) = sign(speed/sqrt(1.0_r8 + ((un*un)/(ue*ue))),ue) + av_d%rAttr(kv,n) = sign(speed/sqrt(1.0_r8 + ((ue*ue)/(un*un))),un) + endif + else + !--- this ignores ur --- + av_d%rAttr(ku,n) = ue + av_d%rAttr(kv,n) = un + endif + enddo + if (trim(type) == 'cart3d_diag' .or. trim(type) == 'cart3d_uvw_diag') then + call mpi_comm_rank(mpicom,my_task,ierr) + call shr_mpi_max(urmaxl,urmax,mpicom,'urmax') + call shr_mpi_sum(uravgl,uravg,mpicom,'uravg') + call shr_mpi_sum(spavgl,spavg,mpicom,'spavg') + call shr_mpi_sum(urcntl,urcnt,mpicom,'urcnt') + if (my_task == 0 .and. urcnt > 0) then + uravg = uravg / urcnt + spavg = spavg / urcnt + write(logunit,*) trim(subname),' cart3d uravg,urmax,spavg = ',uravg,urmax,spavg + endif + endif + + call mct_avect_clean(av3_s) + call mct_avect_clean(av3_d) + + endif ! ku,kv + + end subroutine seq_map_cart3d + + !======================================================================= + + subroutine seq_map_readdata(maprcfile, maprcname, mpicom, ID, & + ni_s, nj_s, av_s, gsmap_s, avfld_s, filefld_s, & + ni_d, nj_d, av_d, gsmap_d, avfld_d, filefld_d, string) + + !--- lifted from work by J Edwards, April 2011 + + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + use pio, only : pio_openfile, pio_closefile, pio_read_darray, pio_inq_dimid, & + pio_inq_dimlen, pio_inq_varid, file_desc_t, io_desc_t, iosystem_desc_t, & + var_desc_t, pio_int, pio_get_var, pio_double, pio_initdecomp, pio_freedecomp + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + character(len=*),intent(in) :: maprcfile + character(len=*),intent(in) :: maprcname + integer(IN) ,intent(in) :: mpicom + integer(IN) ,intent(in) :: ID + integer(IN) ,intent(out) ,optional :: ni_s + integer(IN) ,intent(out) ,optional :: nj_s + type(mct_avect) ,intent(inout),optional :: av_s + type(mct_gsmap) ,intent(in) ,optional :: gsmap_s + character(len=*),intent(in) ,optional :: avfld_s + character(len=*),intent(in) ,optional :: filefld_s + integer(IN) ,intent(out) ,optional :: ni_d + integer(IN) ,intent(out) ,optional :: nj_d + type(mct_avect) ,intent(inout),optional :: av_d + type(mct_gsmap) ,intent(in) ,optional :: gsmap_d + character(len=*),intent(in) ,optional :: avfld_d + character(len=*),intent(in) ,optional :: filefld_d + character(len=*),intent(in) ,optional :: string + ! + ! Local Variables + ! + type(iosystem_desc_t), pointer :: pio_subsystem + integer(IN) :: pio_iotype + type(file_desc_t) :: File ! PIO file pointer + type(io_desc_t) :: iodesc ! PIO parallel io descriptor + integer(IN) :: rcode ! pio routine return code + type(var_desc_t) :: vid ! pio variable ID + integer(IN) :: did ! pio dimension ID + integer(IN) :: na ! size of source domain + integer(IN) :: nb ! size of destination domain + integer(IN) :: i ! index + integer(IN) :: mytask ! my task + integer(IN), pointer :: dof(:) ! DOF pointers for parallel read + character(len=256):: fileName + character(len=64) :: lfld_s, lfld_d, lfile_s, lfile_d + character(*),parameter :: areaAV_field = 'aream' + character(*),parameter :: areafile_s = 'area_a' + character(*),parameter :: areafile_d = 'area_b' + character(len=*),parameter :: subname = "(seq_map_readdata) " + !----------------------------------------------------- + + if (seq_comm_iamroot(CPLID) .and. present(string)) then + write(logunit,'(A)') subname//' called for '//trim(string) + call shr_sys_flush(logunit) + endif + + call MPI_COMM_RANK(mpicom,mytask,rcode) + + lfld_s = trim(areaAV_field) + if (present(avfld_s)) then + lfld_s = trim(avfld_s) + endif + + lfld_d = trim(areaAV_field) + if (present(avfld_d)) then + lfld_s = trim(avfld_d) + endif + + lfile_s = trim(areafile_s) + if (present(filefld_s)) then + lfile_s = trim(filefld_s) + endif + + lfile_d = trim(areafile_d) + if (present(filefld_d)) then + lfile_d = trim(filefld_d) + endif + + call I90_allLoadF(trim(maprcfile),0,mpicom,rcode) + if(rcode /= 0) then + write(logunit,*)"Cant find maprcfile file ",trim(maprcfile) + call shr_sys_abort(trim(subname)//"i90_allLoadF File Not Found") + endif + + call i90_label(trim(maprcname),rcode) + if(rcode /= 0) then + write(logunit,*)"Cant find label ",maprcname + call shr_sys_abort(trim(subname)//"i90_label Not Found") + endif + + call i90_gtoken(filename,rcode) + if(rcode /= 0) then + write(logunit,*)"Error reading token ",filename + call shr_sys_abort(trim(subname)//"i90_gtoken Error on filename read") + endif + + pio_subsystem => shr_pio_getiosys(ID) + pio_iotype = shr_pio_getiotype(ID) + + rcode = pio_openfile(pio_subsystem, File, pio_iotype, filename) + + if (present(ni_s)) then + rcode = pio_inq_dimid (File, 'ni_a', did) ! number of lons in input grid + rcode = pio_inq_dimlen(File, did , ni_s) + end if + if(present(nj_s)) then + rcode = pio_inq_dimid (File, 'nj_a', did) ! number of lats in input grid + rcode = pio_inq_dimlen(File, did , nj_s) + end if + if(present(ni_d)) then + rcode = pio_inq_dimid (File, 'ni_b', did) ! number of lons in output grid + rcode = pio_inq_dimlen(File, did , ni_d) + end if + if(present(nj_d)) then + rcode = pio_inq_dimid (File, 'nj_b', did) ! number of lats in output grid + rcode = pio_inq_dimlen(File, did , nj_d) + endif + + !--- read and load area_a --- + if (present(av_s)) then + if (.not.present(gsmap_s)) then + call shr_sys_abort(trim(subname)//' ERROR av_s must have gsmap_s') + endif + rcode = pio_inq_dimid (File, 'n_a', did) ! size of input vector + rcode = pio_inq_dimlen(File, did , na) + i = mct_avect_indexra(av_s, trim(lfld_s)) + call mct_gsmap_OrderedPoints(gsMap_s, mytask, dof) + call pio_initdecomp(pio_subsystem, pio_double, (/na/), dof, iodesc) + deallocate(dof) + rcode = pio_inq_varid(File,trim(lfile_s),vid) + call pio_read_darray(File, vid, iodesc, av_s%rattr(i,:), rcode) + call pio_freedecomp(File,iodesc) + end if + + !--- read and load area_b --- + if (present(av_d)) then + if (.not.present(gsmap_d)) then + call shr_sys_abort(trim(subname)//' ERROR av_d must have gsmap_d') + endif + rcode = pio_inq_dimid (File, 'n_b', did) ! size of output vector + rcode = pio_inq_dimlen(File, did , nb) + i = mct_avect_indexra(av_d, trim(lfld_d)) + call mct_gsmap_OrderedPoints(gsMap_d, mytask, dof) + call pio_initdecomp(pio_subsystem, pio_double, (/nb/), dof, iodesc) + deallocate(dof) + rcode = pio_inq_varid(File,trim(lfile_d),vid) + call pio_read_darray(File, vid, iodesc, av_d%rattr(i,:), rcode) + call pio_freedecomp(File,iodesc) + endif + + + call pio_closefile(File) + + end subroutine seq_map_readdata + +!======================================================================= + + subroutine seq_map_avNormAvF(mapper, av_i, av_o, avf_i, avfifld, rList, norm) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) , intent(inout) :: mapper ! mapper + type(mct_aVect) , intent(in) :: av_i ! input + type(mct_aVect) , intent(inout) :: av_o ! output + type(mct_aVect) , intent(in) :: avf_i ! extra src "weight" + character(len=*), intent(in) :: avfifld ! field name in avf_i + character(len=*), intent(in),optional :: rList ! fields list + logical , intent(in),optional :: norm ! normalize at end + ! + integer(IN) :: lsize_i, lsize_f, lsize_o, kf, j + real(r8),allocatable :: frac_i(:),frac_o(:) + logical :: lnorm + character(*),parameter :: subName = '(seq_map_avNormAvF) ' + !----------------------------------------------------- + + lnorm = .true. + if (present(norm)) then + lnorm = norm + endif + + lsize_i = mct_aVect_lsize(av_i) + lsize_f = mct_aVect_lsize(avf_i) + + if (lsize_i /= lsize_f) then + write(logunit,*) subname,' ERROR: lsize_i ne lsize_f ',lsize_i,lsize_f + call shr_sys_abort(subname//' ERROR size_i ne lsize_f') + endif + + !--- extract frac_i field from avf_i to pass to seq_map_avNormArr --- + allocate(frac_i(lsize_i)) + do j = 1,lsize_i + kf = mct_aVect_indexRA(avf_i,trim(avfifld)) + frac_i(j) = avf_i%rAttr(kf,j) + enddo + + if (present(rList)) then + call seq_map_avNormArr(mapper, av_i, av_o, frac_i, rList=rList, norm=lnorm) + else + call seq_map_avNormArr(mapper, av_i, av_o, frac_i, norm=lnorm) + endif + + deallocate(frac_i) + + end subroutine seq_map_avNormAvF + +!======================================================================= + + subroutine seq_map_avNormArr(mapper, av_i, av_o, norm_i, rList, norm) + + implicit none + !----------------------------------------------------- + ! + ! Arguments + ! + type(seq_map) , intent(inout) :: mapper! mapper + type(mct_aVect) , intent(in) :: av_i ! input + type(mct_aVect) , intent(inout) :: av_o ! output + real(r8) , intent(in), optional :: norm_i(:) ! source "weight" + character(len=*), intent(in), optional :: rList ! fields list + logical , intent(in), optional :: norm ! normalize at end + ! + ! Local variables + ! + type(mct_sMatp) :: sMatp ! sMat + type(mct_aVect) :: avp_i , avp_o + integer(IN) :: i,j,ier,kf + integer(IN) :: lsize_i,lsize_o + real(r8) :: normval + character(CX) :: lrList + logical :: lnorm + character(*),parameter :: subName = '(seq_map_avNormArr) ' + character(len=*),parameter :: ffld = 'norm8wt' ! want something unique + !----------------------------------------------------- + + sMatp = mapper%sMatp + lsize_i = mct_aVect_lsize(av_i) + lsize_o = mct_aVect_lsize(av_o) + + lnorm = .true. + if (present(norm)) then + lnorm = norm + endif + + if (present(norm_i) .and..not.lnorm) then + write(logunit,*) subname,' ERROR: norm_i and norm = false' + call shr_sys_abort(subname//' ERROR norm_i and norm = false') + endif + + if (present(norm_i)) then + if (size(norm_i) /= lsize_i) then + write(logunit,*) subname,' ERROR: size(norm_i) ne lsize_i ',size(norm_i),lsize_i + call shr_sys_abort(subname//' ERROR size(norm_i) ne lsize_i') + endif + endif + + !--- create temporary avs for mapping --- + + if (present(rList)) then + call mct_aVect_init(avp_i, rList=trim( rList)//':'//ffld, lsize=lsize_i) + call mct_aVect_init(avp_o, rList=trim( rList)//':'//ffld, lsize=lsize_o) + else + lrList = trim(mct_aVect_exportRList2c(av_i)) + call mct_aVect_init(avp_i, rList=trim(lrList)//':'//ffld, lsize=lsize_i) + lrList = trim(mct_aVect_exportRList2c(av_o)) + call mct_aVect_init(avp_o, rList=trim(lrList)//':'//ffld, lsize=lsize_o) + endif + + !--- copy av_i to avp_i and set ffld value to 1.0 + !--- then multiply all fields by norm_i if norm_i exists + !--- this will do the right thing for the norm_i normalization + + call mct_aVect_copy(aVin=av_i, aVout=avp_i, VECTOR=mct_usevector) + kf = mct_aVect_indexRA(avp_i,ffld) + do j = 1,lsize_i + avp_i%rAttr(kf,j) = 1.0_r8 + enddo + + if (present(norm_i)) then + do j = 1,lsize_i + avp_i%rAttr(:,j) = avp_i%rAttr(:,j)*norm_i(j) + enddo + endif + + !--- map --- + + if (mapper%esmf_map) then + call shr_sys_abort(subname//' ERROR: esmf SMM not supported') + else + ! MCT based SMM + call mct_sMat_avMult(avp_i, sMatp, avp_o, VECTOR=mct_usevector) + endif + + !--- renormalize avp_o by mapped norm_i --- + + if (lnorm) then + do j = 1,lsize_o + kf = mct_aVect_indexRA(avp_o,ffld) + normval = avp_o%rAttr(kf,j) + if (normval /= 0.0_r8) then + normval = 1.0_r8/normval + endif + avp_o%rAttr(:,j) = avp_o%rAttr(:,j)*normval + enddo + endif + + !--- copy back into av_o and we are done --- + + call mct_aVect_copy(aVin=avp_o, aVout=av_o, VECTOR=mct_usevector) + + call mct_aVect_clean(avp_i) + call mct_aVect_clean(avp_o) + + end subroutine seq_map_avNormArr + +end module seq_map_mod diff --git a/driver-mct/main/seq_map_type_mod.F90 b/driver-mct/main/seq_map_type_mod.F90 new file mode 100644 index 000000000000..c12e9de99abf --- /dev/null +++ b/driver-mct/main/seq_map_type_mod.F90 @@ -0,0 +1,179 @@ +module seq_map_type_mod + + use shr_kind_mod , only: R8 => SHR_KIND_R8, IN=>SHR_KIND_IN + use shr_kind_mod , only: CL => SHR_KIND_CL, CX => SHR_KIND_CX + use shr_mct_mod , only: shr_mct_sMatPInitnc, shr_mct_queryConfigFile + use shr_sys_mod + use shr_const_mod + use seq_comm_mct, only: logunit, CPLID, seq_comm_iamroot + use mct_mod + + type seq_map + logical :: copy_only + logical :: rearrange_only + logical :: esmf_map + type(mct_rearr) :: rearr + type(mct_sMatp) :: sMatp + ! + !---- for comparing + integer(IN) :: counter ! indicates which seq_maps this mapper points to + character(CL) :: strategy ! indicates the strategy for this mapper, (copy, rearrange, X, Y) + character(CX) :: mapfile ! indicates the mapping file used + type(mct_gsMap),pointer :: gsmap_s + type(mct_gsMap),pointer :: gsmap_d + ! + !---- for cart3d + character(CL) :: cart3d_init + real(R8), pointer :: slon_s(:) + real(R8), pointer :: clon_s(:) + real(R8), pointer :: slat_s(:) + real(R8), pointer :: clat_s(:) + real(R8), pointer :: slon_d(:) + real(R8), pointer :: clon_d(:) + real(R8), pointer :: slat_d(:) + real(R8), pointer :: clat_d(:) + integer(IN) :: mpicom ! mpicom + ! + end type seq_map + public seq_map + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! seq_map_maxcnt is the total number of mappings supported + ! seq_map_cnt is the total number of mappings initialized any any time + ! seq_maps are the mappers that have been initialized + + integer(IN),parameter :: seq_map_maxcnt = 5000 + integer(IN) :: seq_map_cnt = 0 + type(seq_map),private,target :: seq_maps(seq_map_maxcnt) + + ! tcraig, work-in-progress + ! type seq_map_node + ! type(seq_map_node), pointer :: next,prev + ! type(seq_map), pointer :: seq_map + ! end type seq_map_node + ! type(seq_map_node), pointer :: seq_map_list, seq_map_curr + + !=============================================================================== +contains + !=============================================================================== + + subroutine seq_map_mapmatch(mapid,gsMap_s,gsMap_d,mapfile,strategy) + + ! This method searches through the current seq_maps to find a + ! mapping file that matches the values passed in + + implicit none + integer ,intent(out) :: mapid + type(mct_gsMap) ,intent(in),optional :: gsMap_s + type(mct_gsMap) ,intent(in),optional :: gsMap_d + character(len=*),intent(in),optional :: mapfile + character(len=*),intent(in),optional :: strategy + + integer(IN) :: m + logical :: match + character(*),parameter :: subName = '(seq_map_mapmatch) ' + + mapid = -1 + ! tcraig - this return turns off the mapping reuse + ! RETURN + + do m = 1,seq_map_cnt + match = .true. + + if (match .and. present(mapfile)) then + if (trim(mapfile) /= trim(seq_maps(m)%mapfile)) match = .false. + endif + if (match .and. present(strategy)) then + if (trim(strategy) /= trim(seq_maps(m)%strategy)) match = .false. + endif + if (match .and. present(gsMap_s)) then + if (.not.mct_gsmap_Identical(gsmap_s,seq_maps(m)%gsmap_s)) match = .false. + endif + if (match .and. present(gsMap_d)) then + if (.not.mct_gsmap_Identical(gsmap_d,seq_maps(m)%gsmap_d)) match = .false. + endif + + if (match) then + mapid = m + if (seq_comm_iamroot(CPLID)) then + write(logunit,'(A,i6)') subname//' found match ',mapid + call shr_sys_flush(logunit) + endif + return + endif + enddo + + end subroutine seq_map_mapmatch + + !=============================================================================== + + subroutine seq_map_mapinit(mapper,mpicom) + + ! This method initializes a new seq_maps map datatype and + ! has the mapper passed in point to it + + implicit none + type(seq_map) ,intent(inout),pointer :: mapper + integer(IN) ,intent(in) :: mpicom + + character(*),parameter :: subName = '(seq_map_mapinit) ' + + ! set the seq_map data + seq_map_cnt = seq_map_cnt + 1 + if (seq_map_cnt > seq_map_maxcnt) then + write(logunit,*) trim(subname),'seq_map_cnt too large',seq_map_cnt + call shr_sys_abort(subName // "seq_map_cnt bigger than seq_map_maxcnt") + endif + mapper => seq_maps(seq_map_cnt) + mapper%counter = seq_map_cnt + + mapper%copy_only = .false. + mapper%rearrange_only = .false. + mapper%mpicom = mpicom + mapper%strategy = "undefined" + mapper%mapfile = "undefined" + + end subroutine seq_map_mapinit + + !=============================================================================== + + subroutine seq_map_mappoint(mapid,mapper) + + ! This method searches through the current seq_maps to find a + ! mapping file that matches the values passed in + + implicit none + integer ,intent(in) :: mapid + type(seq_map) ,intent(inout),pointer :: mapper + + mapper => seq_maps(mapid) + + end subroutine seq_map_mappoint + + !=============================================================================== + + subroutine seq_map_gsmapcheck(gsmap1,gsmap2) + + ! This method verifies that two gsmaps are of the same global size + + implicit none + type(mct_gsMap),intent(in) :: gsmap1 + type(mct_gsMap),intent(in) :: gsmap2 + + integer(IN) :: s1, s2 + character(*),parameter :: subName = '(seq_map_gsmapcheck) ' + + s1 = mct_gsMap_gsize(gsMap1) + s2 = mct_gsMap_gsize(gsMap2) + if (s1 /= s2) then + write(logunit,*) trim(subname),'gsmap global sizes different ',s1,s2 + call shr_sys_abort(subName // "different gsmap size") + endif + + end subroutine seq_map_gsmapcheck + + +end module seq_map_type_mod diff --git a/driver-mct/main/seq_rest_mod.F90 b/driver-mct/main/seq_rest_mod.F90 new file mode 100644 index 000000000000..50025aa6b63e --- /dev/null +++ b/driver-mct/main/seq_rest_mod.F90 @@ -0,0 +1,534 @@ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_rest_mod -- cpl7 restart reading/writing routines +! +! !DESCRIPTION: +! +! Reads & writes cpl7 restart files +! +! !REMARKS: +! +! aVect, domain, and fraction info accessed via seq_avdata_mod +! to avoid excessively long routine arg lists. +! +! !REVISION HISTORY: +! 2009-Sep-25 - B. Kauffman - move from cpl7 main program into rest module +! 2007-mmm-dd - T. Craig - initial restart functionality +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_rest_mod + +! !USES: + + use shr_kind_mod, only: R8 => SHR_KIND_R8, IN => SHR_KIND_IN + use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use shr_mpi_mod, only: shr_mpi_bcast + use shr_cal_mod, only: shr_cal_date2ymd + use shr_file_mod, only: shr_file_getunit, shr_file_freeunit + use mct_mod + use ESMF + use component_type_mod + + ! diagnostic routines + use seq_diag_mct, only : budg_dataG, budg_ns + + ! Sets mpi communicators, logunit and loglevel + use seq_comm_mct, only: seq_comm_getdata=>seq_comm_setptrs, seq_comm_setnthreads, & + seq_comm_iamin, CPLID, GLOID, logunit, loglevel + + ! "infodata" gathers various control flags into one datatype + use seq_infodata_mod, only: seq_infodata_type, seq_infodata_getData + + ! clock & alarm routines + use seq_timemgr_mod, only: seq_timemgr_type, seq_timemgr_EClockGetData + + ! diagnostic routines + use seq_diag_mct, only: budg_datag + + ! lower level io routines + use seq_io_mod, only: seq_io_read, seq_io_write, seq_io_enddef + use seq_io_mod, only: seq_io_wopen, seq_io_close + + ! prep modules - coupler communication between different components + use prep_ocn_mod, only: prep_ocn_get_x2oacc_ox + use prep_ocn_mod, only: prep_ocn_get_x2oacc_ox_cnt + use prep_rof_mod, only: prep_rof_get_l2racc_lx + use prep_rof_mod, only: prep_rof_get_l2racc_lx_cnt + use prep_glc_mod, only: prep_glc_get_l2gacc_lx + use prep_glc_mod, only: prep_glc_get_l2gacc_lx_cnt + use prep_aoflux_mod, only: prep_aoflux_get_xao_ox + use prep_aoflux_mod, only: prep_aoflux_get_xao_ax + + implicit none + + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS + + public :: seq_rest_read ! read cpl7 restart data + public :: seq_rest_write ! write cpl7 restart data + +! !PUBLIC DATA MEMBERS: + + ! no public data + +!EOP + + !---------------------------------------------------------------------------- + ! local data + !---------------------------------------------------------------------------- + + logical :: iamin_CPLID ! pe associated with CPLID + integer(IN) :: mpicom_GLOID ! MPI global communicator + integer(IN) :: mpicom_CPLID ! MPI cpl communicator + + integer(IN) :: nthreads_GLOID ! OMP global number of threads + integer(IN) :: nthreads_CPLID ! OMP cpl number of threads + logical :: drv_threading ! driver threading control + + logical :: atm_present ! .true. => atm is present + logical :: lnd_present ! .true. => land is present + logical :: ice_present ! .true. => ice is present + logical :: ocn_present ! .true. => ocn is present + logical :: rof_present ! .true. => land runoff is present + logical :: rof_prognostic ! .true. => rof comp expects input + logical :: glc_present ! .true. => glc is present + logical :: wav_present ! .true. => wav is present + logical :: esp_present ! .true. => esp is present + + logical :: atm_prognostic ! .true. => atm comp expects input + logical :: lnd_prognostic ! .true. => lnd comp expects input + logical :: ice_prognostic ! .true. => ice comp expects input + logical :: ocn_prognostic ! .true. => ocn comp expects input + logical :: ocnrof_prognostic ! .true. => ocn comp expects runoff input + logical :: glc_prognostic ! .true. => glc comp expects input + logical :: wav_prognostic ! .true. => wav comp expects input + logical :: esp_prognostic ! .true. => esp comp expects input + + integer(IN) :: info_debug = 0 ! local info_debug level + + !--- temporary pointers --- + type(mct_gsMap), pointer :: gsmap + type(mct_aVect), pointer :: x2oacc_ox(:) + integer , pointer :: x2oacc_ox_cnt + type(mct_aVect), pointer :: l2racc_lx(:) + integer , pointer :: l2racc_lx_cnt + type(mct_aVect), pointer :: l2gacc_lx(:) + integer , pointer :: l2gacc_lx_cnt + type(mct_aVect), pointer :: xao_ox(:) + type(mct_aVect), pointer :: xao_ax(:) + +!=============================================================================== +contains +!=============================================================================== + + subroutine seq_rest_read(rest_file, infodata, & + atm, lnd, ice, ocn, rof, glc, wav, esp, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx) + + implicit none + + character(*) , intent(in) :: rest_file ! restart file path/name + type(seq_infodata_type), intent(in) :: infodata + type (component_type) , intent(inout) :: atm(:) + type (component_type) , intent(inout) :: lnd(:) + type (component_type) , intent(inout) :: ice(:) + type (component_type) , intent(inout) :: ocn(:) + type (component_type) , intent(inout) :: rof(:) + type (component_type) , intent(inout) :: glc(:) + type (component_type) , intent(inout) :: wav(:) + type (component_type) , intent(inout) :: esp(:) + type(mct_aVect) , intent(inout) :: fractions_ax(:) ! Fractions on atm grid/decomp + type(mct_aVect) , intent(inout) :: fractions_lx(:) ! Fractions on lnd grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ix(:) ! Fractions on ice grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ox(:) ! Fractions on ocn grid/decomp + type(mct_aVect) , intent(inout) :: fractions_rx(:) ! Fractions on rof grid/decomp + type(mct_aVect) , intent(inout) :: fractions_gx(:) ! Fractions on glc grid/decomp + type(mct_aVect) , intent(inout) :: fractions_wx(:) ! Fractions on wav grid/decomp + + integer(IN) :: n,n1,n2,n3 + real(r8),allocatable :: ds(:) ! for reshaping diag data for restart file + real(r8),allocatable :: ns(:) ! for reshaping diag data for restart file + character(CS) :: string + integer(IN) :: ierr ! MPI error return + character(len=*), parameter :: subname = "(seq_rest_read) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + + call seq_comm_getdata(GLOID,& + mpicom=mpicom_GLOID, nthreads=nthreads_GLOID) + call seq_comm_getdata(CPLID, & + mpicom=mpicom_CPLID, nthreads=nthreads_CPLID) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present, & + esp_present=esp_present, & + atm_prognostic=atm_prognostic, & + lnd_prognostic=lnd_prognostic, & + ice_prognostic=ice_prognostic, & + ocn_prognostic=ocn_prognostic, & + rof_prognostic=rof_prognostic, & + ocnrof_prognostic=ocnrof_prognostic, & + glc_prognostic=glc_prognostic, & + wav_prognostic=wav_prognostic, & + esp_prognostic=esp_prognostic) + + if (iamin_CPLID) then + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + if (atm_present) then + gsmap => component_get_gsmap_cx(atm(1)) + xao_ax => prep_aoflux_get_xao_ax() + call seq_io_read(rest_file, gsmap, fractions_ax, 'fractions_ax') + call seq_io_read(rest_file, atm, 'c2x', 'a2x_ax') + call seq_io_read(rest_file, gsmap, xao_ax, 'xao_ax') + endif + if (lnd_present) then + gsmap => component_get_gsmap_cx(lnd(1)) + call seq_io_read(rest_file, gsmap, fractions_lx, 'fractions_lx') + endif + if (lnd_present .and. rof_prognostic) then + gsmap => component_get_gsmap_cx(lnd(1)) + l2racc_lx => prep_rof_get_l2racc_lx() + l2racc_lx_cnt => prep_rof_get_l2racc_lx_cnt() + call seq_io_read(rest_file, gsmap, l2racc_lx, 'l2racc_lx') + call seq_io_read(rest_file, l2racc_lx_cnt ,'l2racc_lx_cnt') + end if + if (lnd_present .and. glc_prognostic) then + gsmap => component_get_gsmap_cx(lnd(1)) + l2gacc_lx => prep_glc_get_l2gacc_lx() + l2gacc_lx_cnt => prep_glc_get_l2gacc_lx_cnt() + call seq_io_read(rest_file, gsmap, l2gacc_lx, 'l2gacc_lx') + call seq_io_read(rest_file, l2gacc_lx_cnt ,'l2gacc_lx_cnt') + end if + if (ocn_present) then + gsmap => component_get_gsmap_cx(ocn(1)) + x2oacc_ox => prep_ocn_get_x2oacc_ox() + x2oacc_ox_cnt => prep_ocn_get_x2oacc_ox_cnt() + xao_ox => prep_aoflux_get_xao_ox() + call seq_io_read(rest_file, gsmap, fractions_ox, 'fractions_ox') + call seq_io_read(rest_file, ocn, 'c2x', 'o2x_ox') ! get o2x_ox + call seq_io_read(rest_file, gsmap, x2oacc_ox, 'x2oacc_ox') + call seq_io_read(rest_file, x2oacc_ox_cnt, 'x2oacc_ox_cnt') + call seq_io_read(rest_file, gsmap, xao_ox, 'xao_ox') + endif + if (ice_present) then + gsmap => component_get_gsmap_cx(ice(1)) + call seq_io_read(rest_file, gsmap, fractions_ix, 'fractions_ix') + call seq_io_read(rest_file, ice, 'c2x', 'i2x_ix') + endif + if (rof_present) then + gsmap => component_get_gsmap_cx(rof(1)) + call seq_io_read(rest_file, gsmap, fractions_rx, 'fractions_rx') + call seq_io_read(rest_file, rof, 'c2x', 'r2x_rx') + endif + if (glc_present) then + gsmap => component_get_gsmap_cx(glc(1)) + call seq_io_read(rest_file, gsmap, fractions_gx, 'fractions_gx') + call seq_io_read(rest_file, glc, 'c2x', 'g2x_gx') + endif + if (wav_present) then + gsmap => component_get_gsmap_cx(wav(1)) + call seq_io_read(rest_file, gsmap, fractions_wx, 'fractions_wx') + call seq_io_read(rest_file, wav, 'c2x', 'w2x_wx') + endif + ! Add ESP restart read here + + n = size(budg_dataG) + allocate(ds(n),ns(n)) + call seq_io_read(rest_file, ds, 'budg_dataG') + call seq_io_read(rest_file, ns, 'budg_ns') + + n = 0 + do n1 = 1,size(budg_dataG,dim=1) + do n2 = 1,size(budg_dataG,dim=2) + do n3 = 1,size(budg_dataG,dim=3) + n = n + 1 + budg_dataG(n1,n2,n3) = ds(n) + budg_ns (n1,n2,n3) = ns(n) + enddo + enddo + enddo +! call shr_mpi_bcast(budg_dataG,cpl_io_root) ! not necessary, io lib does bcast + + deallocate(ds,ns) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + + endif + +end subroutine seq_rest_read + +!=============================================================================== + +subroutine seq_rest_write(EClock_d, seq_SyncClock, infodata, & + atm, lnd, ice, ocn, rof, glc, wav, esp, & + fractions_ax, fractions_lx, fractions_ix, fractions_ox, & + fractions_rx, fractions_gx, fractions_wx, tag) + + implicit none + + type(ESMF_Clock) , intent(in) :: EClock_d ! driver clock + type(seq_timemgr_type) , intent(inout) :: seq_SyncClock ! contains ptr to driver clock + type(seq_infodata_type), intent(in) :: infodata + type (component_type) , intent(inout) :: atm(:) + type (component_type) , intent(inout) :: lnd(:) + type (component_type) , intent(inout) :: ice(:) + type (component_type) , intent(inout) :: ocn(:) + type (component_type) , intent(inout) :: rof(:) + type (component_type) , intent(inout) :: glc(:) + type (component_type) , intent(inout) :: wav(:) + type (component_type) , intent(inout) :: esp(:) + type(mct_aVect) , intent(inout) :: fractions_ax(:) ! Fractions on atm grid/decomp + type(mct_aVect) , intent(inout) :: fractions_lx(:) ! Fractions on lnd grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ix(:) ! Fractions on ice grid/decomp + type(mct_aVect) , intent(inout) :: fractions_ox(:) ! Fractions on ocn grid/decomp + type(mct_aVect) , intent(inout) :: fractions_rx(:) ! Fractions on rof grid/decomp + type(mct_aVect) , intent(inout) :: fractions_gx(:) ! Fractions on glc grid/decomp + type(mct_aVect) , intent(inout) :: fractions_wx(:) ! Fractions on wav grid/decomp + character(len=*) , intent(in) :: tag + + integer(IN) :: n,n1,n2,n3,fk + integer(IN) :: curr_ymd ! Current date YYYYMMDD + integer(IN) :: curr_tod ! Current time-of-day (s) + integer(IN) :: yy,mm,dd ! year, month, day + character(CL) :: case_name ! case name + character(CL) :: cvar ! char variable + integer(IN) :: ivar ! integer variable + real(r8) :: rvar ! real variable + logical :: whead,wdata ! flags header/data writing + logical :: cplroot ! root pe on cpl id + integer(IN) :: iun ! unit number + character(CL) :: rest_file ! Local path to restart filename + integer(IN) :: ierr ! MPI error return + type(mct_gsMap),pointer :: gsmap + + real(r8),allocatable :: ds(:) ! for reshaping diag data for restart file + real(r8),allocatable :: ns(:) ! for reshaping diag data for restart file + character(len=*),parameter :: subname = "(seq_rest_write) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! get required infodata + !---------------------------------------------------------------------------- + iamin_CPLID = seq_comm_iamin(CPLID) + + call seq_comm_getdata(GLOID,& + mpicom=mpicom_GLOID, nthreads=nthreads_GLOID) + + call seq_comm_getdata(CPLID,& + mpicom=mpicom_CPLID, nthreads=nthreads_CPLID, iamroot=cplroot) + + call seq_infodata_getData(infodata, & + drv_threading=drv_threading, & + atm_present=atm_present, & + lnd_present=lnd_present, & + rof_present=rof_present, & + ice_present=ice_present, & + ocn_present=ocn_present, & + glc_present=glc_present, & + wav_present=wav_present, & + esp_present=esp_present, & + atm_prognostic=atm_prognostic, & + lnd_prognostic=lnd_prognostic, & + ice_prognostic=ice_prognostic, & + rof_prognostic=rof_prognostic, & + ocn_prognostic=ocn_prognostic, & + ocnrof_prognostic=ocnrof_prognostic, & + glc_prognostic=glc_prognostic, & + wav_prognostic=wav_prognostic, & + esp_prognostic=esp_prognostic, & + case_name=case_name) + + ! Write out infodata and time manager data to restart file + + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=curr_ymd, curr_tod=curr_tod) + call shr_cal_date2ymd(curr_ymd,yy,mm,dd) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.cpl'//trim(tag)//'.r.',yy,'-',mm,'-',dd,'-',curr_tod,'.nc' + + ! Write driver data to restart file + + if (iamin_CPLID) then + + if (drv_threading) call seq_comm_setnthreads(nthreads_CPLID) + + ! copy budg_dataG into 1d array + n = size(budg_dataG) + allocate(ds(n),ns(n)) + call shr_mpi_bcast(budg_dataG,mpicom_CPLID) ! pio requires data on all pe's? + + n = 0 + do n1 = 1,size(budg_dataG,dim=1) + do n2 = 1,size(budg_dataG,dim=2) + do n3 = 1,size(budg_dataG,dim=3) + n = n + 1 + ds(n) = budg_dataG(n1,n2,n3) + ns(n) = budg_ns(n1,n2,n3) + enddo + enddo + enddo + + if (cplroot) then + iun = shr_file_getUnit() + call seq_infodata_GetData(infodata,restart_pfile=cvar) + if (loglevel > 0) write(logunit,"(3A)") subname," write rpointer file ", & + trim(cvar) + open(iun, file=cvar, form='FORMATTED') + write(iun,'(a)') rest_file + close(iun) + call shr_file_freeUnit( iun ) + endif + + call shr_mpi_bcast(rest_file,mpicom_CPLID) + call seq_io_wopen(rest_file,clobber=.true.) + + ! loop twice (for perf), first time write header, second time write data + do fk = 1,2 + if (fk == 1) then + whead = .true. + wdata = .false. + elseif (fk == 2) then + whead = .false. + wdata = .true. + call seq_io_enddef(rest_file) + else + call shr_sys_abort('driver_write_rstart fk illegal') + end if + call seq_infodata_GetData(infodata,nextsw_cday=rvar) + call seq_io_write(rest_file,rvar,'seq_infodata_nextsw_cday',whead=whead,wdata=wdata) + call seq_infodata_GetData(infodata,precip_fact=rvar) + call seq_io_write(rest_file,rvar,'seq_infodata_precip_fact',whead=whead,wdata=wdata) + call seq_infodata_GetData(infodata,case_name=cvar) + call seq_io_write(rest_file,trim(cvar),'seq_infodata_case_name',whead=whead,wdata=wdata) + + call seq_timemgr_EClockGetData( EClock_d, start_ymd=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_start_ymd',whead=whead,wdata=wdata) + call seq_timemgr_EClockGetData( EClock_d, start_tod=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_start_tod',whead=whead,wdata=wdata) + call seq_timemgr_EClockGetData( EClock_d, ref_ymd=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_ref_ymd' ,whead=whead,wdata=wdata) + call seq_timemgr_EClockGetData( EClock_d, ref_tod=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_ref_tod' ,whead=whead,wdata=wdata) + call seq_timemgr_EClockGetData( EClock_d, curr_ymd=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_curr_ymd' ,whead=whead,wdata=wdata) + call seq_timemgr_EClockGetData( EClock_d, curr_tod=ivar) + call seq_io_write(rest_file,ivar,'seq_timemgr_curr_tod' ,whead=whead,wdata=wdata) + + call seq_io_write(rest_file,ds,'budg_dataG',whead=whead,wdata=wdata) + call seq_io_write(rest_file,ns,'budg_ns',whead=whead,wdata=wdata) + + if (atm_present) then + gsmap => component_get_gsmap_cx(atm(1)) + xao_ax => prep_aoflux_get_xao_ax() + call seq_io_write(rest_file, gsmap, fractions_ax, 'fractions_ax', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, atm, 'c2x', 'a2x_ax', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, gsmap, xao_ax, 'xao_ax', & + whead=whead, wdata=wdata) + endif + if (lnd_present) then + gsmap => component_get_gsmap_cx(lnd(1)) + call seq_io_write(rest_file, gsmap, fractions_lx, 'fractions_lx', & + whead=whead, wdata=wdata) + endif + if (lnd_present .and. rof_prognostic) then + gsmap => component_get_gsmap_cx(lnd(1)) + l2racc_lx => prep_rof_get_l2racc_lx() + l2racc_lx_cnt => prep_rof_get_l2racc_lx_cnt() + call seq_io_write(rest_file, gsmap, l2racc_lx, 'l2racc_lx', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, l2racc_lx_cnt, 'l2racc_lx_cnt', & + whead=whead, wdata=wdata) + end if + if (lnd_present .and. glc_prognostic) then + gsmap => component_get_gsmap_cx(lnd(1)) + l2gacc_lx => prep_glc_get_l2gacc_lx() + l2gacc_lx_cnt => prep_glc_get_l2gacc_lx_cnt() + call seq_io_write(rest_file, gsmap, l2gacc_lx, 'l2gacc_lx', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, l2gacc_lx_cnt, 'l2gacc_lx_cnt', & + whead=whead, wdata=wdata) + end if + if (ocn_present) then + gsmap => component_get_gsmap_cx(ocn(1)) + x2oacc_ox => prep_ocn_get_x2oacc_ox() + x2oacc_ox_cnt => prep_ocn_get_x2oacc_ox_cnt() + xao_ox => prep_aoflux_get_xao_ox() + call seq_io_write(rest_file, gsmap, fractions_ox, 'fractions_ox', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, ocn, 'c2x', 'o2x_ox', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, gsmap, x2oacc_ox, 'x2oacc_ox', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, x2oacc_ox_cnt, 'x2oacc_ox_cnt', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, gsmap, xao_ox, 'xao_ox', & + whead=whead, wdata=wdata) + endif + if (ice_present) then + gsmap => component_get_gsmap_cx(ice(1)) + call seq_io_write(rest_file, gsmap, fractions_ix, 'fractions_ix', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, ice, 'c2x', 'i2x_ix', & + whead=whead, wdata=wdata) + endif + if (rof_present) then + gsmap => component_get_gsmap_cx(rof(1)) + call seq_io_write(rest_file, gsmap, fractions_rx, 'fractions_rx', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, rof, 'c2x', 'r2x_rx', & + whead=whead, wdata=wdata) + endif + if (glc_present) then + gsmap => component_get_gsmap_cx(glc(1)) + call seq_io_write(rest_file, gsmap, fractions_gx, 'fractions_gx', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, glc, 'c2x', 'g2x_gx', & + whead=whead, wdata=wdata) + endif + if (wav_present) then + gsmap => component_get_gsmap_cx(wav(1)) + call seq_io_write(rest_file, gsmap, fractions_wx, 'fractions_wx', & + whead=whead, wdata=wdata) + call seq_io_write(rest_file, wav, 'c2x', 'w2x_wx', & + whead=whead, wdata=wdata) + endif + ! Write ESP restart data here + enddo + + call seq_io_close(rest_file) + deallocate(ds,ns) + + if (drv_threading) call seq_comm_setnthreads(nthreads_GLOID) + endif +end subroutine seq_rest_write + +!=============================================================================== + +end module seq_rest_mod diff --git a/driver-mct/main/t_driver_timers_mod.F90 b/driver-mct/main/t_driver_timers_mod.F90 new file mode 100644 index 000000000000..00b3ebdcba14 --- /dev/null +++ b/driver-mct/main/t_driver_timers_mod.F90 @@ -0,0 +1,116 @@ +module t_drv_timers_mod + + use perf_mod + integer, private :: cpl_run_hash=0, cpl_comm_hash=0, cpl_budget_hash=0 + character(len=*),parameter :: strcpl = 'CPL:RUN' + character(len=*),parameter :: strcom = 'CPL:COMM' + character(len=*),parameter :: strbud = 'CPL:BUDGET' + +contains + + !=============================================================================== + + subroutine t_drvstartf(string,cplrun,cplcom,budget,barrier, hashint) + + implicit none + + character(len=*),intent(in) :: string + logical,intent(in),optional :: cplrun + logical,intent(in),optional :: cplcom + logical,intent(in),optional :: budget + integer,intent(in),optional :: barrier + integer,intent(inout), optional :: hashint + + character(len=128) :: strbar + + logical :: lcplrun,lcplcom,lbudget + !------------------------------------------------------------------------------- + + lcplrun = .false. + lcplcom = .false. + lbudget = .false. + if (present(cplrun)) then + lcplrun = cplrun + endif + if (present(cplcom)) then + lcplcom = cplcom + endif + if (present(budget)) then + lbudget = budget + endif + + if (present(barrier)) then + strbar = trim(string)//'_BARRIER' + call t_barrierf (trim(strbar), barrier) + endif + + if (lcplrun) then + call t_startf (trim(strcpl), cpl_run_hash) + call t_adj_detailf(+1) + endif + + if (lcplcom) then + call t_startf (trim(strcom), cpl_comm_hash) + call t_adj_detailf(+1) + endif + + if (lbudget) then + call t_startf (trim(strbud), cpl_budget_hash) + call t_adj_detailf(+1) + endif + + call t_startf (trim(string),hashint) + call t_adj_detailf(+1) + + end subroutine t_drvstartf + + !=============================================================================== + + subroutine t_drvstopf(string,cplrun,cplcom,budget,hashint) + + implicit none + + character(len=*),intent(in) :: string + logical,intent(in),optional :: cplrun + logical,intent(in),optional :: cplcom + logical,intent(in),optional :: budget + integer, intent(in), optional :: hashint + character(len=128) :: strbar + logical :: lcplrun,lcplcom,lbudget + + !------------------------------------------------------------------------------- + + lcplrun = .false. + lcplcom = .false. + lbudget = .false. + if (present(cplrun)) then + lcplrun = cplrun + endif + if (present(cplcom)) then + lcplcom = cplcom + endif + if (present(budget)) then + lbudget = budget + endif + + call t_adj_detailf(-1) + call t_stopf (trim(string), hashint) + + if (lbudget) then + call t_adj_detailf(-1) + call t_stopf (trim(strbud), cpl_budget_hash) + endif + + if (lcplrun) then + call t_adj_detailf(-1) + call t_stopf (trim(strcpl), cpl_run_hash) + endif + + if (lcplcom) then + call t_adj_detailf(-1) + call t_stopf (trim(strcom),cpl_comm_hash) + endif + + end subroutine t_drvstopf + +end module t_drv_timers_mod diff --git a/driver-mct/shr/CMakeLists.txt b/driver-mct/shr/CMakeLists.txt new file mode 100644 index 000000000000..37bf92fb905f --- /dev/null +++ b/driver-mct/shr/CMakeLists.txt @@ -0,0 +1,9 @@ +list(APPEND drv_sources + glc_elevclass_mod.F90 + seq_cdata_mod.F90 + seq_comm_mct.F90 + seq_infodata_mod.F90 + seq_io_read_mod.F90 + ) + +sourcelist_to_parent(drv_sources) diff --git a/driver-mct/shr/glc_elevclass_mod.F90 b/driver-mct/shr/glc_elevclass_mod.F90 new file mode 100644 index 000000000000..d68ae8fed2cc --- /dev/null +++ b/driver-mct/shr/glc_elevclass_mod.F90 @@ -0,0 +1,423 @@ +module glc_elevclass_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains data and routines for operating on GLC elevation classes. + +#include "shr_assert.h" + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_sys_mod + use seq_comm_mct, only : logunit + use shr_log_mod, only : errMsg => shr_log_errMsg + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: glc_elevclass_init ! initialize GLC elevation class data + public :: glc_elevclass_clean ! deallocate memory allocated here + public :: glc_get_num_elevation_classes ! get the number of elevation classes + public :: glc_get_elevation_class ! get the elevation class index for a given elevation + public :: glc_get_elevclass_bounds ! get the boundaries of all elevation classes + public :: glc_mean_elevation_virtual ! get the mean elevation of a virtual elevation class + public :: glc_elevclass_as_string ! returns a string corresponding to a given elevation class + public :: glc_all_elevclass_strings ! returns an array of strings for all elevation classes + public :: glc_errcode_to_string ! convert an error code into a string describing the error + + interface glc_elevclass_init + module procedure glc_elevclass_init_default + module procedure glc_elevclass_init_override + end interface glc_elevclass_init + + + !-------------------------------------------------------------------------- + ! Public data + !-------------------------------------------------------------------------- + + ! Possible error code values + integer, parameter, public :: GLC_ELEVCLASS_ERR_NONE = 0 ! err_code indicating no error + integer, parameter, public :: GLC_ELEVCLASS_ERR_UNDEFINED = 1 ! err_code indicating elevation classes have not been defined + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_LOW = 2 ! err_code indicating topo below lowest elevation class + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_HIGH = 3 ! err_code indicating topo above highest elevation class + + ! String length for glc elevation classes represented as strings + integer, parameter, public :: GLC_ELEVCLASS_STRLEN = 2 + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! number of elevation classes + integer :: glc_nec + + ! upper elevation limit of each class (m) + ! indexing starts at 0, with topomax(0) giving the lower elevation limit of EC 1 + real(r8), allocatable :: topomax(:) + + +contains + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_default(my_glc_nec) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to default boundaries, based on given glc_nec + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_elevclass_init' + !----------------------------------------------------------------------- + + glc_nec = my_glc_nec + allocate(topomax(0:glc_nec)) + + select case (glc_nec) + case(0) + ! do nothing + case(1) + topomax = [0._r8, 10000._r8] + case(3) + topomax = [0._r8, 1000._r8, 2000._r8, 10000._r8] + case(5) + topomax = [0._r8, 500._r8, 1000._r8, 1500._r8, 2000._r8, 10000._r8] + case(10) + topomax = [0._r8, 200._r8, 400._r8, 700._r8, 1000._r8, 1300._r8, & + 1600._r8, 2000._r8, 2500._r8, 3000._r8, 10000._r8] + case(36) + topomax = [ 0._r8, 200._r8, 400._r8, 600._r8, 800._r8, & + 1000._r8, 1200._r8, 1400._r8, 1600._r8, 1800._r8, & + 2000._r8, 2200._r8, 2400._r8, 2600._r8, 2800._r8, & + 3000._r8, 3200._r8, 3400._r8, 3600._r8, 3800._r8, & + 4000._r8, 4200._r8, 4400._r8, 4600._r8, 4800._r8, & + 5000._r8, 5200._r8, 5400._r8, 5600._r8, 5800._r8, & + 6000._r8, 6200._r8, 6400._r8, 6600._r8, 6800._r8, & + 7000._r8, 10000._r8] + case default + write(logunit,*) subname,' ERROR: unknown glc_nec: ', glc_nec + call shr_sys_abort(subname//' ERROR: unknown glc_nec') + end select + + end subroutine glc_elevclass_init_default + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_override(my_glc_nec, my_topomax) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to the given elevation class boundaries. + ! + ! The input, my_topomax, should have (my_glc_nec + 1) elements. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + real(r8), intent(in) :: my_topomax(0:) ! elevation class boundaries (m) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_elevclass_init_override' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(my_topomax) == (/my_glc_nec/)), __FILE__, __LINE__) + + glc_nec = my_glc_nec + allocate(topomax(0:glc_nec)) + topomax = my_topomax + + end subroutine glc_elevclass_init_override + + !----------------------------------------------------------------------- + subroutine glc_elevclass_clean() + ! + ! !DESCRIPTION: + ! Deallocate memory allocated in this module + + character(len=*), parameter :: subname = 'glc_elevclass_clean' + !----------------------------------------------------------------------- + + if (allocated(topomax)) then + deallocate(topomax) + end if + glc_nec = 0 + + end subroutine glc_elevclass_clean + + !----------------------------------------------------------------------- + function glc_get_num_elevation_classes() result(num_elevation_classes) + ! + ! !DESCRIPTION: + ! Get the number of GLC elevation classes + ! + ! !ARGUMENTS: + integer :: num_elevation_classes ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_num_elevation_classes' + !----------------------------------------------------------------------- + + num_elevation_classes = glc_nec + + end function glc_get_num_elevation_classes + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_class(topo, elevation_class, err_code) + ! + ! !DESCRIPTION: + ! Get the elevation class index associated with a given topographic height. + ! + ! The returned elevation_class will be between 1 and num_elevation_classes, if this + ! topographic height is contained in an elevation class. In this case, err_code will + ! be GLC_ELEVCLASS_ERR_NONE (no error). + ! + ! If there are no elevation classes defined, the returned value will be 0, and + ! err_code will be GLC_ELEVCLASS_ERR_UNDEFINED + ! + ! If this topographic height is below the lowest elevation class, the returned value + ! will be 1, and err_code will be GLC_ELEVCLASS_ERR_TOO_LOW. + ! + ! If this topographic height is above the highest elevation class, the returned value + ! will be (num_elevation_classes), and err_code will be GLC_ELEVCLASS_ERR_TOO_HIGH. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: topo ! topographic height (m) + integer, intent(out) :: elevation_class ! elevation class index + integer, intent(out) :: err_code ! error code (see above for possible codes) + ! + ! !LOCAL VARIABLES: + integer :: ec ! temporary elevation class + + character(len=*), parameter :: subname = 'glc_get_elevation_class' + !----------------------------------------------------------------------- + + if (glc_nec < 1) then + elevation_class = 0 + err_code = GLC_ELEVCLASS_ERR_UNDEFINED + else if (topo < topomax(0)) then + elevation_class = 1 + err_code = GLC_ELEVCLASS_ERR_TOO_LOW + else if (topo >= topomax(glc_nec)) then + elevation_class = glc_nec + err_code = GLC_ELEVCLASS_ERR_TOO_HIGH + else + err_code = GLC_ELEVCLASS_ERR_NONE + elevation_class = 0 + do ec = 1, glc_nec + if (topo >= topomax(ec - 1) .and. topo < topomax(ec)) then + elevation_class = ec + exit + end if + end do + + SHR_ASSERT(elevation_class > 0, subname//' elevation class was not assigned') + end if + + end subroutine glc_get_elevation_class + + !----------------------------------------------------------------------- + function glc_get_elevclass_bounds() result(elevclass_bounds) + ! + ! !DESCRIPTION: + ! Get the boundaries of all elevation classes. + ! + ! This returns an array of size glc_nec+1, since it contains both the lower and upper + ! bounds of each elevation class. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8) :: elevclass_bounds(0:glc_nec) ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_elevclass_bounds' + !----------------------------------------------------------------------- + + elevclass_bounds(:) = topomax(:) + + end function glc_get_elevclass_bounds + + + !----------------------------------------------------------------------- + function glc_mean_elevation_virtual(elevation_class) result(mean_elevation) + ! + ! !DESCRIPTION: + ! Returns the mean elevation of a virtual elevation class + ! + ! !ARGUMENTS: + real(r8) :: mean_elevation ! function result + integer, intent(in) :: elevation_class + ! + ! !LOCAL VARIABLES: + integer :: resulting_elevation_class + integer :: err_code + + character(len=*), parameter :: subname = 'glc_mean_elevation_virtual' + !----------------------------------------------------------------------- + + if (elevation_class == 0) then + ! Bare land "elevation class" + mean_elevation = 0._r8 + else + if (elevation_class < glc_nec) then + ! Normal case + mean_elevation = (topomax(elevation_class - 1) + topomax(elevation_class)) / 2._r8 + else if (elevation_class == glc_nec) then + ! In the top elevation class; in this case, assignment of a "mean" elevation is + ! somewhat arbitrary (because we expect the upper bound of the top elevation + ! class to be very high). + + if (glc_nec > 1) then + mean_elevation = 2._r8 * topomax(elevation_class - 1) - topomax(elevation_class - 2) + else + ! entirely arbitrary + mean_elevation = 1000._r8 + end if + else + write(logunit,*) subname,' ERROR: elevation class out of bounds: ', elevation_class + call shr_sys_abort(subname // ' ERROR: elevation class out of bounds') + end if + end if + + ! Ensure that the resulting elevation is within the given elevation class + if (elevation_class > 0) then + call glc_get_elevation_class(mean_elevation, resulting_elevation_class, err_code) + if (err_code /= GLC_ELEVCLASS_ERR_NONE) then + write(logunit,*) subname, ' ERROR: generated elevation that results in an error' + write(logunit,*) 'when trying to determine the resulting elevation class' + write(logunit,*) glc_errcode_to_string(err_code) + write(logunit,*) 'elevation_class, mean_elevation = ', elevation_class, mean_elevation + call shr_sys_abort(subname // ' ERROR: generated elevation that results in an error') + else if (resulting_elevation_class /= elevation_class) then + write(logunit,*) subname, ' ERROR: generated elevation outside the given elevation class' + write(logunit,*) 'elevation_class, mean_elevation, resulting_elevation_class = ', & + elevation_class, mean_elevation, resulting_elevation_class + call shr_sys_abort(subname // ' ERROR: generated elevation outside the given elevation class') + end if + end if + + end function glc_mean_elevation_virtual + + + !----------------------------------------------------------------------- + function glc_elevclass_as_string(elevation_class) result(ec_string) + ! + ! !DESCRIPTION: + ! Returns a string corresponding to a given elevation class. + ! + ! This string can be used as a suffix for fields in MCT attribute vectors. + ! + ! ! NOTE(wjs, 2015-01-19) This function doesn't fully belong in this module, since it + ! doesn't refer to the data stored in this module. However, I can't think of a more + ! appropriate place for it. + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=GLC_ELEVCLASS_STRLEN) :: ec_string ! function result + integer, intent(in) :: elevation_class + ! + ! !LOCAL VARIABLES: + character(len=16) :: format_string + + character(len=*), parameter :: subname = 'glc_elevclass_as_string' + !----------------------------------------------------------------------- + + ! e.g., for GLC_ELEVCLASS_STRLEN = 2, format_string will be '(i2.2)' + write(format_string,'(a,i0,a,i0,a)') '(i', GLC_ELEVCLASS_STRLEN, '.', GLC_ELEVCLASS_STRLEN, ')' + + write(ec_string,trim(format_string)) elevation_class + end function glc_elevclass_as_string + + !----------------------------------------------------------------------- + function glc_all_elevclass_strings(include_zero) result(ec_strings) + ! + ! !DESCRIPTION: + ! Returns an array of strings corresponding to all elevation classes from 1 to glc_nec + ! + ! If include_zero is present and true, then includes elevation class 0 - so goes from + ! 0 to glc_nec + ! + ! These strings can be used as suffixes for fields in MCT attribute vectors. + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=GLC_ELEVCLASS_STRLEN), allocatable :: ec_strings(:) ! function result + logical, intent(in), optional :: include_zero ! if present and true, include elevation class 0 (default is false) + ! + ! !LOCAL VARIABLES: + logical :: l_include_zero ! local version of optional include_zero argument + integer :: lower_bound + integer :: i + + character(len=*), parameter :: subname = 'glc_all_elevclass_strings' + !----------------------------------------------------------------------- + + if (present(include_zero)) then + l_include_zero = include_zero + else + l_include_zero = .false. + end if + + if (l_include_zero) then + lower_bound = 0 + else + lower_bound = 1 + end if + + allocate(ec_strings(lower_bound:glc_nec)) + do i = lower_bound, glc_nec + ec_strings(i) = glc_elevclass_as_string(i) + end do + + end function glc_all_elevclass_strings + + + !----------------------------------------------------------------------- + function glc_errcode_to_string(err_code) result(err_string) + ! + ! !DESCRIPTION: + ! + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=256) :: err_string ! function result + integer, intent(in) :: err_code ! error code (one of the GLC_ELEVCLASS_ERR* values) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_errcode_to_string' + !----------------------------------------------------------------------- + + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + err_string = '(no error)' + case (GLC_ELEVCLASS_ERR_UNDEFINED) + err_string = 'Elevation classes have not yet been defined' + case (GLC_ELEVCLASS_ERR_TOO_LOW) + err_string = 'Topographic height below the lower bound of the lowest elevation class' + case (GLC_ELEVCLASS_ERR_TOO_HIGH) + err_string = 'Topographic height above the upper bound of the highest elevation class' + case default + err_string = 'UNKNOWN ERROR' + end select + + end function glc_errcode_to_string + + +end module glc_elevclass_mod diff --git a/driver-mct/shr/seq_cdata_mod.F90 b/driver-mct/shr/seq_cdata_mod.F90 new file mode 100644 index 000000000000..d35f922e31b6 --- /dev/null +++ b/driver-mct/shr/seq_cdata_mod.F90 @@ -0,0 +1,106 @@ +module seq_cdata_mod + + use shr_kind_mod , only: r8=> shr_kind_r8 + use shr_sys_mod , only: shr_sys_flush + use shr_sys_mod , only: shr_sys_abort + use seq_infodata_mod , only: seq_infodata_type + use mct_mod + use seq_comm_mct + + implicit none + save + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + public :: seq_cdata_setptrs + public :: seq_cdata_init ! only used by xxx_comp_esm.F90 for data models + + !-------------------------------------------------------------------------- + ! Public data + !-------------------------------------------------------------------------- + ! in general, this type just groups together related data via pointers + + type seq_cdata + character(len=16) :: name ! user defined name + integer :: ID ! component id + integer :: mpicom ! mpi communicator + type(mct_gGrid) ,pointer :: dom => null() ! domain info + type(mct_gsMap) ,pointer :: gsMap => null() ! decomp info + type(seq_infodata_type) ,pointer :: infodata => null() ! Input init object + end type seq_cdata + + public seq_cdata + +!============================================================================== +contains +!============================================================================== + + subroutine seq_cdata_setptrs(cdata, ID, mpicom, dom, gsMap, infodata, name) + + !----------------------------------------------------------------------- + ! + ! Arguments + type(seq_cdata) ,intent(in) :: cdata ! input + integer ,optional :: ID ! component id + integer ,optional :: mpicom ! mpi comm + type(mct_gGrid) ,optional,pointer :: dom ! domain + type(mct_gsMap) ,optional,pointer :: gsMap ! decomp + type(seq_infodata_type) ,optional,pointer :: infodata ! INIT object + character(len=*) ,optional :: name ! name + ! + ! Local variables + character(*),parameter :: subName = '(seq_cdata_setptrs) ' + !----------------------------------------------------------------------- + + if (present(name )) name = cdata%name + if (present(ID )) ID = cdata%ID + if (present(mpicom )) mpicom = cdata%mpicom + if (present(dom )) dom => cdata%dom + if (present(gsMap )) gsMap => cdata%gsMap + if (present(infodata )) infodata => cdata%infodata + + end subroutine seq_cdata_setptrs + + !=============================================================================== + + subroutine seq_cdata_init(cdata,ID,dom,gsMap,infodata,name) + + !----------------------------------------------------------------------- + ! Description + ! This is here only for backwards compatibility with current data model + ! xxx_comp_esmf.F90 interfaces + ! + ! Arguments + implicit none + type(seq_cdata) ,intent(inout) :: cdata ! initialized + integer ,intent(in) :: ID ! component id + type(mct_gGrid) ,intent(in),target :: dom ! domain + type(mct_gsMap) ,intent(in),target :: gsMap ! decomp + type(seq_infodata_type) ,intent(in),target :: infodata ! INIT object + character(len=*) ,intent(in),optional :: name ! user defined name + ! + ! Local variables + ! + integer :: mpicom ! mpi communicator + character(*),parameter :: subName = '(seq_cdata_init) ' + logical :: iamroot ! iamroot + !----------------------------------------------------------------------- + + call seq_comm_setptrs(ID, mpicom=mpicom, iamroot=iamroot) + + if (present(name)) then + cdata%name = name + else + cdata%name = 'undefined' + endif + cdata%ID = ID + cdata%mpicom = mpicom + cdata%dom => dom + cdata%gsMap => gsMap + cdata%infodata => infodata + + end subroutine seq_cdata_init + +end module seq_cdata_mod diff --git a/driver-mct/shr/seq_comm_mct.F90 b/driver-mct/shr/seq_comm_mct.F90 new file mode 100644 index 000000000000..c89d9bd30cdd --- /dev/null +++ b/driver-mct/shr/seq_comm_mct.F90 @@ -0,0 +1,1319 @@ +module seq_comm_mct + +!--------------------------------------------------------------------- +! +! Purpose: Set up necessary communications +! Note that if no MPI, will call MCTs fake version +! (including mpif.h) will be utilized +! +!--------------------------------------------------------------------- + + +!!! NOTE: If all atmospheres are identical in number of processes, +!!! number of threads, and grid layout, we should check that the +!!! user-provided number of processes and threads are consistent +!!! (or else, only accept one entry for these quantities when reading +!!! the namelist). ARE OTHER PROTECTIONS/CHECKS NEEDED??? + + + use mct_mod , only : mct_world_init, mct_world_clean, mct_die + use shr_sys_mod , only : shr_sys_abort, shr_sys_flush + use shr_mpi_mod , only : shr_mpi_chkerr, shr_mpi_bcast, shr_mpi_max + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use esmf , only : ESMF_LogKind_Flag, ESMF_LOGKIND_NONE + use esmf , only : ESMF_LOGKIND_SINGLE, ESMF_LOGKIND_MULTI + + implicit none + + private +#include + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public seq_comm_init + public seq_comm_clean + public seq_comm_iamin + public seq_comm_iamroot + public seq_comm_mpicom + public seq_comm_iam + public seq_comm_gloiam + public seq_comm_gloroot + public seq_comm_cplpe + public seq_comm_cmppe + public seq_comm_name + public seq_comm_inst + public seq_comm_suffix + public seq_comm_setptrs + public seq_comm_setnthreads + public seq_comm_getnthreads + public seq_comm_printcomms + public seq_comm_get_ncomps + +!-------------------------------------------------------------------------- +! Public data +!-------------------------------------------------------------------------- + + integer, public, parameter :: default_logunit = 6 + integer, public :: logunit = default_logunit ! log unit number + integer, public :: loglevel = 1 ! log level + + integer, public :: global_mype = -1 !! To be initialized + + !!! Note - NUM_COMP_INST_XXX are cpp variables set in buildlib.csm_share + + integer, parameter :: ncomptypes = 8 ! total number of component types + integer, parameter :: ncouplers = 1 ! number of couplers + integer, parameter, public :: num_inst_atm = NUM_COMP_INST_ATM + integer, parameter, public :: num_inst_lnd = NUM_COMP_INST_LND + integer, parameter, public :: num_inst_ocn = NUM_COMP_INST_OCN + integer, parameter, public :: num_inst_ice = NUM_COMP_INST_ICE + integer, parameter, public :: num_inst_glc = NUM_COMP_INST_GLC + integer, parameter, public :: num_inst_wav = NUM_COMP_INST_WAV + integer, parameter, public :: num_inst_rof = NUM_COMP_INST_ROF + integer, parameter, public :: num_inst_esp = NUM_COMP_INST_ESP + + integer, parameter, public :: num_inst_total= num_inst_atm + & + num_inst_lnd + & + num_inst_ocn + & + num_inst_ice + & + num_inst_glc + & + num_inst_wav + & + num_inst_rof + & + num_inst_esp + 1 + + integer, public :: num_inst_min, num_inst_max + integer, public :: num_inst_xao ! for xao flux + integer, public :: num_inst_frc ! for fractions + integer, public :: num_inst_driver = 1 + + !!! Each component instance needs two communicators: one internal to the + !!! instance, and one for communicating with the coupler. + !!! Additionally, one communicator is needed for the coupler's + !!! internal communications, and one is needed for the global space. + !!! All instances of a component type also share a separate communicator + !!! All instances of a component type share a communicator with the coupler + + integer, parameter, public :: num_inst_phys = num_inst_atm + num_inst_lnd + & + num_inst_ocn + num_inst_ice + & + num_inst_glc + num_inst_rof + & + num_inst_wav + num_inst_esp + integer, parameter, public :: num_cpl_phys = num_inst_atm + num_inst_lnd + & + num_inst_ocn + num_inst_ice + & + num_inst_glc + num_inst_rof + & + num_inst_wav + num_inst_esp + integer, parameter :: ncomps = (1 + ncouplers + 2*ncomptypes + num_inst_phys + num_cpl_phys) + + integer, public :: GLOID + integer, public :: CPLID + + integer, public :: ALLATMID + integer, public :: ALLLNDID + integer, public :: ALLOCNID + integer, public :: ALLICEID + integer, public :: ALLGLCID + integer, public :: ALLROFID + integer, public :: ALLWAVID + integer, public :: ALLESPID + + integer, public :: CPLALLATMID + integer, public :: CPLALLLNDID + integer, public :: CPLALLOCNID + integer, public :: CPLALLICEID + integer, public :: CPLALLGLCID + integer, public :: CPLALLROFID + integer, public :: CPLALLWAVID + integer, public :: CPLALLESPID + + integer, public :: ATMID(num_inst_atm) + integer, public :: LNDID(num_inst_lnd) + integer, public :: OCNID(num_inst_ocn) + integer, public :: ICEID(num_inst_ice) + integer, public :: GLCID(num_inst_glc) + integer, public :: ROFID(num_inst_rof) + integer, public :: WAVID(num_inst_wav) + integer, public :: ESPID(num_inst_esp) + + integer, public :: CPLATMID(num_inst_atm) + integer, public :: CPLLNDID(num_inst_lnd) + integer, public :: CPLOCNID(num_inst_ocn) + integer, public :: CPLICEID(num_inst_ice) + integer, public :: CPLGLCID(num_inst_glc) + integer, public :: CPLROFID(num_inst_rof) + integer, public :: CPLWAVID(num_inst_wav) + integer, public :: CPLESPID(num_inst_esp) + + type(ESMF_LogKind_Flag), public :: esmf_logfile_kind + + integer, parameter, public :: seq_comm_namelen=16 + + ! suffix for log and timing files if multi coupler driver + character(len=seq_comm_namelen), public :: cpl_inst_tag + + type seq_comm_type + character(len=seq_comm_namelen) :: name ! my name + character(len=seq_comm_namelen) :: suffix ! recommended suffix + integer :: inst ! my inst index + integer :: ID ! my id number + integer :: mpicom ! mpicom + integer :: mpigrp ! mpigrp + integer :: npes ! number of mpi tasks in comm + integer :: nthreads ! number of omp threads per task + integer :: iam ! my task number in mpicom + logical :: iamroot ! am i the root task in mpicom + + integer :: gloiam ! my task number in global_comm + integer :: gloroot ! the global task number of each comps root on all pes + + integer :: pethreads ! max number of threads on my task + integer :: cplpe ! a common task in mpicom from the cpl group for join mpicoms + ! cplpe is used to broadcast information from the coupler to the component + integer :: cmppe ! a common task in mpicom from the component group for join mpicoms + ! cmppe is used to broadcast information from the component to the coupler + logical :: set ! has this datatype been set + + end type seq_comm_type + + type(seq_comm_type) :: seq_comms(ncomps) + + character(*), parameter :: layout_concurrent = 'concurrent' + character(*), parameter :: layout_sequential = 'sequential' + + character(*), parameter :: F11 = "(a,a,'(',i3,' ',a,')',a, 3i6,' (',a,i6,')',' (',a,i3,')','(',a,a,')')" + character(*), parameter :: F12 = "(a,a,'(',i3,' ',a,')',a,2i6,6x,' (',a,i6,')',' (',a,i3,')','(',a,2i6,')')" + character(*), parameter :: F13 = "(a,a,'(',i3,' ',a,')',a,2i6,6x,' (',a,i6,')',' (',a,i3,')')" + character(*), parameter :: F14 = "(a,a,'(',i3,' ',a,')',a, 6x,' (',a,i6,')',' (',a,i3,')')" + + ! Exposed for use in the esp component, please don't use this elsewhere + integer, public :: Global_Comm + integer :: driver_comm + + character(len=32), public :: & + atm_layout, lnd_layout, ice_layout, glc_layout, rof_layout, & + ocn_layout, wav_layout, esp_layout + + logical :: seq_comm_mct_initialized = .false. ! whether this module has been initialized + +!======================================================================= +contains +!====================================================================== + integer function seq_comm_get_ncomps() + seq_comm_get_ncomps = ncomps + end function seq_comm_get_ncomps + + subroutine seq_comm_init(global_comm_in, driver_comm_in, nmlfile, drv_comm_id) + !---------------------------------------------------------- + ! + ! Arguments + implicit none + integer, intent(in) :: global_comm_in + integer, intent(in) :: driver_comm_in + character(len=*), intent(IN) :: nmlfile + integer, intent(in), optional :: drv_comm_id + ! + ! Local variables + ! + logical :: error_state + integer :: ierr, n, count + character(*), parameter :: subName = '(seq_comm_init) ' + integer :: mype,numpes,myncomps,max_threads,gloroot, global_numpes + integer :: pelist(3,1) ! start, stop, stride for group + integer, pointer :: comps(:) ! array with component ids + integer, pointer :: comms(:) ! array with mpicoms + integer :: nu + + integer :: & + atm_ntasks, atm_rootpe, atm_pestride, atm_nthreads, & + lnd_ntasks, lnd_rootpe, lnd_pestride, lnd_nthreads, & + ice_ntasks, ice_rootpe, ice_pestride, ice_nthreads, & + glc_ntasks, glc_rootpe, glc_pestride, glc_nthreads, & + wav_ntasks, wav_rootpe, wav_pestride, wav_nthreads, & + rof_ntasks, rof_rootpe, rof_pestride, rof_nthreads, & + ocn_ntasks, ocn_rootpe, ocn_pestride, ocn_nthreads, & + esp_ntasks, esp_rootpe, esp_pestride, esp_nthreads, & + cpl_ntasks, cpl_rootpe, cpl_pestride, cpl_nthreads + + namelist /ccsm_pes/ & + atm_ntasks, atm_rootpe, atm_pestride, atm_nthreads, atm_layout, & + lnd_ntasks, lnd_rootpe, lnd_pestride, lnd_nthreads, lnd_layout, & + ice_ntasks, ice_rootpe, ice_pestride, ice_nthreads, ice_layout, & + glc_ntasks, glc_rootpe, glc_pestride, glc_nthreads, glc_layout, & + wav_ntasks, wav_rootpe, wav_pestride, wav_nthreads, wav_layout, & + rof_ntasks, rof_rootpe, rof_pestride, rof_nthreads, rof_layout, & + ocn_ntasks, ocn_rootpe, ocn_pestride, ocn_nthreads, ocn_layout, & + esp_ntasks, esp_rootpe, esp_pestride, esp_nthreads, esp_layout, & + cpl_ntasks, cpl_rootpe, cpl_pestride, cpl_nthreads + !---------------------------------------------------------- + + ! make sure this is first pass and set comms unset + if (seq_comm_mct_initialized) then + write(logunit,*) trim(subname),' ERROR seq_comm_init already called ' + call shr_sys_abort() + endif + seq_comm_mct_initialized = .true. + global_comm = global_comm_in + driver_comm = driver_comm_in + + !! Initialize seq_comms elements + + do n = 1,ncomps + seq_comms(n)%name = 'unknown' + seq_comms(n)%suffix = ' ' + seq_comms(n)%inst = 0 + seq_comms(n)%set = .false. + seq_comms(n)%mpicom = MPI_COMM_NULL ! do some initialization here + seq_comms(n)%iam = -1 + seq_comms(n)%iamroot = .false. + seq_comms(n)%npes = -1 + seq_comms(n)%nthreads = -1 + seq_comms(n)%gloiam = -1 + seq_comms(n)%gloroot = -1 + seq_comms(n)%pethreads = -1 + seq_comms(n)%cplpe = -1 + seq_comms(n)%cmppe = -1 + enddo + + + ! Initialize MPI + ! Note that if no MPI, will call MCTs fake version + + call mpi_comm_size(GLOBAL_COMM_IN, global_numpes , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') + call mpi_comm_rank(DRIVER_COMM, mype , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank driver') + call mpi_comm_size(DRIVER_COMM, numpes, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size driver') + + if (mod(global_numpes, numpes) .ne. 0) then + write(logunit,*) trim(subname),' ERROR: numpes driver: ', numpes, ' should divide global_numpes: ',global_numpes + call shr_sys_abort(trim(subname)//' ERROR decomposition error ') + endif + + ! Initialize gloiam on all IDs + + global_mype = mype + + do n = 1,ncomps + seq_comms(n)%gloiam = mype + enddo + + ! Set ntasks, rootpe, pestride, nthreads for all components + + if (mype == 0) then + !! Set up default component process parameters + call comp_pelayout_init(numpes, atm_ntasks, atm_rootpe, atm_pestride, atm_nthreads, atm_layout) + call comp_pelayout_init(numpes, lnd_ntasks, lnd_rootpe, lnd_pestride, lnd_nthreads, lnd_layout) + call comp_pelayout_init(numpes, ice_ntasks, ice_rootpe, ice_pestride, ice_nthreads, ice_layout) + call comp_pelayout_init(numpes, ocn_ntasks, ocn_rootpe, ocn_pestride, ocn_nthreads, ocn_layout) + call comp_pelayout_init(numpes, rof_ntasks, rof_rootpe, rof_pestride, rof_nthreads, rof_layout) + call comp_pelayout_init(numpes, wav_ntasks, wav_rootpe, wav_pestride, wav_nthreads, wav_layout) + call comp_pelayout_init(numpes, glc_ntasks, glc_rootpe, glc_pestride, glc_nthreads, glc_layout) + call comp_pelayout_init(numpes, esp_ntasks, esp_rootpe, esp_pestride, esp_nthreads, esp_layout) + call comp_pelayout_init(numpes, cpl_ntasks, cpl_rootpe, cpl_pestride, cpl_nthreads) + + ! Read namelist if it exists + + nu = shr_file_getUnit() + open(nu, file=trim(nmlfile), status='old', iostat=ierr) + + if (ierr == 0) then + ierr = 1 + do while( ierr > 0 ) + read(nu, nml=ccsm_pes, iostat=ierr) + end do + close(nu) + end if + call shr_file_freeUnit(nu) + end if + + call shr_mpi_bcast(atm_nthreads,DRIVER_COMM,'atm_nthreads') + call shr_mpi_bcast(lnd_nthreads,DRIVER_COMM,'lnd_nthreads') + call shr_mpi_bcast(ocn_nthreads,DRIVER_COMM,'ocn_nthreads') + call shr_mpi_bcast(ice_nthreads,DRIVER_COMM,'ice_nthreads') + call shr_mpi_bcast(glc_nthreads,DRIVER_COMM,'glc_nthreads') + call shr_mpi_bcast(wav_nthreads,DRIVER_COMM,'wav_nthreads') + call shr_mpi_bcast(rof_nthreads,DRIVER_COMM,'rof_nthreads') + call shr_mpi_bcast(esp_nthreads,DRIVER_COMM,'esp_nthreads') + call shr_mpi_bcast(cpl_nthreads,DRIVER_COMM,'cpl_nthreads') + + call shr_mpi_bcast(atm_layout,DRIVER_COMM,'atm_layout') + call shr_mpi_bcast(lnd_layout,DRIVER_COMM,'lnd_layout') + call shr_mpi_bcast(ocn_layout,DRIVER_COMM,'ocn_layout') + call shr_mpi_bcast(ice_layout,DRIVER_COMM,'ice_layout') + call shr_mpi_bcast(glc_layout,DRIVER_COMM,'glc_layout') + call shr_mpi_bcast(wav_layout,DRIVER_COMM,'wav_layout') + call shr_mpi_bcast(rof_layout,DRIVER_COMM,'rof_layout') + call shr_mpi_bcast(esp_layout,DRIVER_COMM,'esp_layout') + + + !--- compute some other num_inst values + + num_inst_xao = max(num_inst_atm,num_inst_ocn) + num_inst_frc = num_inst_ice + + !--- compute num_inst_min, num_inst_max + !--- instances must be either 1 or a constant across components + !--- checks for prognostic/present consistency in the driver + + error_state = .false. + num_inst_min = min(num_inst_atm, num_inst_lnd, num_inst_ocn,& + num_inst_ice, num_inst_glc, num_inst_wav, num_inst_rof,& + num_inst_esp) + num_inst_max = max(num_inst_atm, num_inst_lnd, num_inst_ocn,& + num_inst_ice, num_inst_glc, num_inst_wav, num_inst_rof,& + num_inst_esp) + + if (num_inst_min /= num_inst_max .and. num_inst_min /= 1) error_state = .true. + if (num_inst_atm /= num_inst_min .and. num_inst_atm /= num_inst_max) error_state = .true. + if (num_inst_lnd /= num_inst_min .and. num_inst_lnd /= num_inst_max) error_state = .true. + if (num_inst_ocn /= num_inst_min .and. num_inst_ocn /= num_inst_max) error_state = .true. + if (num_inst_ice /= num_inst_min .and. num_inst_ice /= num_inst_max) error_state = .true. + if (num_inst_glc /= num_inst_min .and. num_inst_glc /= num_inst_max) error_state = .true. + if (num_inst_wav /= num_inst_min .and. num_inst_wav /= num_inst_max) error_state = .true. + if (num_inst_rof /= num_inst_min .and. num_inst_rof /= num_inst_max) error_state = .true. + if (num_inst_esp /= num_inst_min .and. num_inst_esp /= num_inst_max) error_state = .true. + + if (error_state) then + write(logunit,*) trim(subname),' ERROR: num_inst inconsistent' + write(logunit,*) num_inst_atm, num_inst_lnd, num_inst_ocn,& + num_inst_ice, num_inst_glc, num_inst_wav, num_inst_rof,& + num_inst_esp, num_inst_min, num_inst_max + call shr_sys_abort(trim(subname)//' ERROR: num_inst inconsistent') + endif + + ! Initialize IDs + + count = 0 + + count = count + 1 + GLOID = count + count = count + 1 + CPLID = count + + if (mype == 0) then + pelist(1,1) = 0 + pelist(2,1) = numpes-1 + pelist(3,1) = 1 + end if + call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, DRIVER_COMM, ierr) + call seq_comm_setcomm(GLOID, pelist,iname='GLOBAL') + + if (mype == 0) then + pelist(1,1) = cpl_rootpe + pelist(2,1) = cpl_rootpe + (cpl_ntasks -1) * cpl_pestride + pelist(3,1) = cpl_pestride + end if + call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, DRIVER_COMM, ierr) + call seq_comm_setcomm(CPLID,pelist,cpl_nthreads,'CPL') + + call comp_comm_init(driver_comm, atm_rootpe, atm_nthreads, atm_layout, atm_ntasks, atm_pestride, num_inst_atm, & + CPLID, ATMID, CPLATMID, ALLATMID, CPLALLATMID, 'ATM', count, drv_comm_id) + call comp_comm_init(driver_comm, lnd_rootpe, lnd_nthreads, lnd_layout, lnd_ntasks, lnd_pestride, num_inst_lnd, & + CPLID, LNDID, CPLLNDID, ALLLNDID, CPLALLLNDID, 'LND', count, drv_comm_id) + call comp_comm_init(driver_comm, ice_rootpe, ice_nthreads, ice_layout, ice_ntasks, ice_pestride, num_inst_ice, & + CPLID, ICEID, CPLICEID, ALLICEID, CPLALLICEID, 'ICE', count, drv_comm_id) + call comp_comm_init(driver_comm, ocn_rootpe, ocn_nthreads, ocn_layout, ocn_ntasks, ocn_pestride, num_inst_ocn, & + CPLID, OCNID, CPLOCNID, ALLOCNID, CPLALLOCNID, 'OCN', count, drv_comm_id) + call comp_comm_init(driver_comm, rof_rootpe, rof_nthreads, rof_layout, rof_ntasks, rof_pestride, num_inst_rof, & + CPLID, ROFID, CPLROFID, ALLROFID, CPLALLROFID, 'ROF', count, drv_comm_id) + call comp_comm_init(driver_comm, glc_rootpe, glc_nthreads, glc_layout, glc_ntasks, glc_pestride, num_inst_glc, & + CPLID, GLCID, CPLGLCID, ALLGLCID, CPLALLGLCID, 'GLC', count, drv_comm_id) + call comp_comm_init(driver_comm, wav_rootpe, wav_nthreads, wav_layout, wav_ntasks, wav_pestride, num_inst_wav, & + CPLID, WAVID, CPLWAVID, ALLWAVID, CPLALLWAVID, 'WAV', count, drv_comm_id) + call comp_comm_init(driver_comm, esp_rootpe, esp_nthreads, esp_layout, esp_ntasks, esp_pestride, num_inst_esp, & + CPLID, ESPID, CPLESPID, ALLESPID, CPLALLESPID, 'ESP', count, drv_comm_id) + + if (count /= ncomps) then + write(logunit,*) trim(subname),' ERROR in ID count ',count,ncomps + call shr_sys_abort(trim(subname)//' ERROR in ID count') + endif + !! Count the total number of threads + + max_threads = -1 + do n = 1,ncomps + max_threads = max(max_threads,seq_comms(n)%nthreads) + enddo + do n = 1,ncomps + seq_comms(n)%pethreads = max_threads + enddo + + ! compute each components root pe global id and broadcast so all pes have info + + do n = 1,ncomps + gloroot = -999 + if (seq_comms(n)%iamroot) gloroot = seq_comms(n)%gloiam + call shr_mpi_max(gloroot,seq_comms(n)%gloroot,DRIVER_COMM, & + trim(subname)//' gloroot',all=.true.) + enddo + + ! Initialize MCT + + ! add up valid comps on local pe + + myncomps = 0 + do n = 1,ncomps + if (seq_comms(n)%mpicom /= MPI_COMM_NULL) then + myncomps = myncomps + 1 + endif + enddo + + ! set comps and comms + + allocate(comps(myncomps),comms(myncomps),stat=ierr) + if(ierr/=0) call mct_die(subName,'allocate comps comms',ierr) + + myncomps = 0 + do n = 1,ncomps + if (seq_comms(n)%mpicom /= MPI_COMM_NULL) then + myncomps = myncomps + 1 + if (myncomps > size(comps)) then + write(logunit,*) trim(subname),' ERROR in myncomps ',myncomps,size(comps) + call shr_sys_abort() + endif + comps(myncomps) = seq_comms(n)%ID + comms(myncomps) = seq_comms(n)%mpicom + endif + enddo + + if (myncomps /= size(comps)) then + write(logunit,*) trim(subname),' ERROR in myncomps ',myncomps,size(comps) + call shr_sys_abort() + endif + + call mct_world_init(ncomps, DRIVER_COMM, comms, comps) + + deallocate(comps,comms) + + + call seq_comm_printcomms() + + end subroutine seq_comm_init + + subroutine comp_comm_init(driver_comm, comp_rootpe, comp_nthreads, comp_layout, & + comp_ntasks, comp_pestride, num_inst_comp, & + CPLID, COMPID, CPLCOMPID, ALLCOMPID, CPLALLCOMPID, name, count, drv_comm_id) + integer, intent(in) :: driver_comm + integer, intent(in) :: comp_rootpe + integer, intent(in) :: comp_nthreads + character(len=*), intent(in) :: comp_layout + integer, intent(in) :: comp_ntasks + integer, intent(in) :: comp_pestride + integer, intent(in) :: num_inst_comp + integer, intent(in) :: CPLID + integer, intent(out) :: COMPID(num_inst_comp) + integer, intent(out) :: CPLCOMPID(num_inst_comp) + integer, intent(out) :: ALLCOMPID + integer, intent(out) :: CPLALLCOMPID + integer, intent(inout) :: count + integer, intent(in), optional :: drv_comm_id + character(len=*), intent(in) :: name + + character(len=*), parameter :: subname = "comp_comm_init" + integer :: comp_inst_tasks + integer :: droot + integer :: current_task_rootpe + integer :: cmin(num_inst_comp), cmax(num_inst_comp), cstr(num_inst_comp) + integer :: n + integer :: pelist (3,1) + integer :: ierr + integer :: mype + + call mpi_comm_rank(driver_comm, mype, ierr) + + count = count + 1 + ALLCOMPID = count + count = count + 1 + CPLALLCOMPID = count + do n = 1, num_inst_comp + count = count + 1 + COMPID(n) = count + count = count + 1 + CPLCOMPID(n) = count + enddo + + if (mype == 0) then + !--- validation of inputs --- + ! rootpes >= 0 + !! Determine the process layout + !! + !! We will assign comp_ntasks / num_inst_comp tasks to each component + !! instance. (This may lead to unallocated tasks if comp_ntasks is + !! not an integer multiple of num_inst_comp.) + + if (comp_rootpe < 0) then + call shr_sys_abort(trim(subname)//' ERROR: rootpes must be >= 0 for component '//trim(name)) + endif + + if (trim(comp_layout) == trim(layout_concurrent)) then + comp_inst_tasks = comp_ntasks / num_inst_comp + droot = (comp_inst_tasks * comp_pestride) + elseif (trim(comp_layout) == trim(layout_sequential)) then + comp_inst_tasks = comp_ntasks + droot = 0 + else + call shr_sys_abort(subname//' ERROR invalid comp_layout for component '//trim(name)) + endif + current_task_rootpe = comp_rootpe + do n = 1, num_inst_comp + cmin(n) = current_task_rootpe + cmax(n) = current_task_rootpe & + + ((comp_inst_tasks - 1) * comp_pestride) + cstr(n) = comp_pestride + current_task_rootpe = current_task_rootpe + droot + end do + endif + do n = 1, num_inst_comp + if (mype==0) then + pelist(1,1) = cmin(n) + pelist(2,1) = cmax(n) + pelist(3,1) = cstr(n) + endif + call mpi_bcast(pelist, size(pelist), MPI_INTEGER, 0, DRIVER_COMM, ierr) + if (present(drv_comm_id)) then + call seq_comm_setcomm(COMPID(n), pelist, comp_nthreads,name, drv_comm_id) + else + call seq_comm_setcomm(COMPID(n), pelist, comp_nthreads,name, n, num_inst_comp) + endif + call seq_comm_joincomm(CPLID, COMPID(n), CPLCOMPID(n), 'CPL'//name, n, num_inst_comp) + enddo + call seq_comm_jcommarr(COMPID, ALLCOMPID, 'ALL'//name//'ID', 1, 1) + call seq_comm_joincomm(CPLID, ALLCOMPID, CPLALLCOMPID, 'CPLALL'//name//'ID', 1, 1) + + end subroutine comp_comm_init + + subroutine comp_pelayout_init(numpes, ntasks, rootpe, pestride, nthreads, layout) + integer,intent(in) :: numpes + integer,intent(out) :: ntasks, rootpe, pestride, nthreads + character(len=*),optional :: layout + + ntasks = numpes + rootpe = 0 + pestride = 1 + nthreads = 1 + if(present(layout)) then + layout = trim(layout_concurrent) + endif + end subroutine comp_pelayout_init + +!--------------------------------------------------------- + subroutine seq_comm_clean() + ! Resets this module - freeing memory, etc. + ! + ! This potentially allows seq_comm_init can be called again, e.g., from unit tests. + ! + ! Also calls mct_world_clean, to be symmetric with the mct_world_init call from + ! seq_comm_init. + + integer :: id + + character(*), parameter :: subName = '(seq_comm_clean) ' + !---------------------------------------------------------- + + if (.not. seq_comm_mct_initialized) then + write(logunit,*) trim(subname),' ERROR seq_comm_init has not been called ' + call shr_sys_abort() + end if + seq_comm_mct_initialized = .false. + + call mct_world_clean() + + end subroutine seq_comm_clean + +!--------------------------------------------------------- + subroutine seq_comm_setcomm(ID,pelist,nthreads,iname,inst,tinst) + + implicit none + integer,intent(IN) :: ID + integer,intent(IN) :: pelist(:,:) + integer,intent(IN),optional :: nthreads + character(len=*),intent(IN),optional :: iname ! name of component + integer,intent(IN),optional :: inst ! instance of component + integer,intent(IN),optional :: tinst ! total number of instances for this component + + integer :: mpigrp_world + integer :: mpigrp + integer :: mpicom + integer :: ntask,ntasks,cnt + integer :: ierr + character(len=seq_comm_namelen) :: cname + logical :: set_suffix + character(*),parameter :: subName = '(seq_comm_setcomm) ' + + if (ID < 1 .or. ID > ncomps) then + write(logunit,*) subname,' ID out of range, abort ',ID + call shr_sys_abort() + endif + + call mpi_comm_group(DRIVER_COMM, mpigrp_world, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_group mpigrp_world') + call mpi_group_range_incl(mpigrp_world, 1, pelist, mpigrp,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_group_range_incl mpigrp') + call mpi_comm_create(DRIVER_COMM, mpigrp, mpicom, ierr) + + call shr_mpi_chkerr(ierr,subname//' mpi_comm_create mpigrp') + + ntasks = ((pelist(2,1) - pelist(1,1)) / pelist(3,1)) + 1 + + seq_comms(ID)%set = .true. + seq_comms(ID)%ID = ID + + if (present(inst)) then + seq_comms(ID)%inst = inst + set_suffix = .true. + else + seq_comms(ID)%inst = 1 + set_suffix = .false. + endif + + if (present(tinst)) then + if (tinst == 1) set_suffix = .false. + endif + + if (present(iname)) then + seq_comms(ID)%name = trim(iname) + if (set_suffix) then + call seq_comm_mkname(cname,iname,seq_comms(ID)%inst) + seq_comms(ID)%name = trim(cname) + endif + endif + + if (set_suffix) then + call seq_comm_mkname(cname,'_',seq_comms(ID)%inst) + seq_comms(ID)%suffix = trim(cname) + else + seq_comms(ID)%suffix = ' ' + endif + + seq_comms(ID)%mpicom = mpicom + seq_comms(ID)%mpigrp = mpigrp + if (present(nthreads)) then + seq_comms(ID)%nthreads = nthreads + else + seq_comms(ID)%nthreads = 1 + endif + + if (mpicom /= MPI_COMM_NULL) then + call mpi_comm_size(mpicom,seq_comms(ID)%npes,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size') + call mpi_comm_rank(mpicom,seq_comms(ID)%iam,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank') + if (seq_comms(ID)%iam == 0) then + seq_comms(ID)%iamroot = .true. + else + seq_comms(ID)%iamroot = .false. + endif + else + seq_comms(ID)%npes = -1 + seq_comms(ID)%iam = -1 + seq_comms(ID)%nthreads = 1 + seq_comms(ID)%iamroot = .false. + endif + + if (seq_comms(ID)%iamroot) then + write(logunit,F11) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & + ' pelist =',pelist,' npes =',seq_comms(ID)%npes,' nthreads =',seq_comms(ID)%nthreads,& + ' suffix =',trim(seq_comms(ID)%suffix) + endif + + end subroutine seq_comm_setcomm + +!--------------------------------------------------------- + subroutine seq_comm_joincomm(ID1,ID2,ID,iname,inst,tinst) + + implicit none + integer,intent(IN) :: ID1 ! src id + integer,intent(IN) :: ID2 ! srd id + integer,intent(IN) :: ID ! computed id + character(len=*),intent(IN),optional :: iname ! comm name + integer,intent(IN),optional :: inst + integer,intent(IN),optional :: tinst + + integer :: mpigrp + integer :: mpicom + integer :: ierr + character(len=seq_comm_namelen) :: cname + logical :: set_suffix + integer,allocatable :: pe_t1(:),pe_t2(:) + character(*),parameter :: subName = '(seq_comm_joincomm) ' + + ! check that IDs are in valid range, that ID1 and ID2 have + ! been set, and that ID has not been set + + if (ID1 < 1 .or. ID1 > ncomps) then + write(logunit,*) subname,' ID1 out of range, abort ',ID1 + call shr_sys_abort() + endif + if (ID2 < 1 .or. ID2 > ncomps) then + write(logunit,*) subname,' ID2 out of range, abort ',ID2 + call shr_sys_abort() + endif + if (ID < 1 .or. ID > ncomps) then + write(logunit,*) subname,' ID out of range, abort ',ID + call shr_sys_abort() + endif + if (.not. seq_comms(ID1)%set .or. .not. seq_comms(ID2)%set) then + write(logunit,*) subname,' ID1 or ID2 not set ',ID1,ID2 + call shr_sys_abort() + endif + if (seq_comms(ID)%set) then + write(logunit,*) subname,' ID already set ',ID + call shr_sys_abort() + endif + + call mpi_group_union(seq_comms(ID1)%mpigrp,seq_comms(ID2)%mpigrp,mpigrp,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_union mpigrp') + call mpi_comm_create(DRIVER_COMM, mpigrp, mpicom, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_create mpigrp') + + seq_comms(ID)%set = .true. + seq_comms(ID)%ID = ID + + if (present(inst)) then + seq_comms(ID)%inst = inst + else + seq_comms(ID)%inst = 1 + endif + + set_suffix = .true. + if (present(tinst)) then + if (tinst == 1) set_suffix = .false. + endif + + if (present(iname)) then + seq_comms(ID)%name = trim(iname) + if (set_suffix) then + call seq_comm_mkname(cname,iname,seq_comms(ID)%inst) + seq_comms(ID)%name = trim(cname) + endif + endif + + if (set_suffix) then + call seq_comm_mkname(cname,'_',seq_comms(ID)%inst) + seq_comms(ID)%suffix = trim(cname) + else + seq_comms(ID)%suffix = ' ' + endif + + seq_comms(ID)%mpicom = mpicom + seq_comms(ID)%mpigrp = mpigrp + seq_comms(ID)%nthreads = max(seq_comms(ID1)%nthreads,seq_comms(ID2)%nthreads) + seq_comms(ID)%nthreads = max(seq_comms(ID)%nthreads,1) + + if (mpicom /= MPI_COMM_NULL) then + call mpi_comm_size(mpicom,seq_comms(ID)%npes,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size') + call mpi_comm_rank(mpicom,seq_comms(ID)%iam,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank') + if (seq_comms(ID)%iam == 0) then + seq_comms(ID)%iamroot = .true. + else + seq_comms(ID)%iamroot = .false. + endif + else + seq_comms(ID)%npes = -1 + seq_comms(ID)%iam = -1 + seq_comms(ID)%iamroot = .false. + endif + + allocate(pe_t1(1),pe_t2(1)) + pe_t1(1) = 0 + call mpi_group_translate_ranks(seq_comms(ID1)%mpigrp, 1, pe_t1, mpigrp, pe_t2, ierr) + seq_comms(ID)%cplpe = pe_t2(1) + pe_t1(1) = 0 + call mpi_group_translate_ranks(seq_comms(ID2)%mpigrp, 1, pe_t1, mpigrp, pe_t2, ierr) + seq_comms(ID)%cmppe = pe_t2(1) + deallocate(pe_t1,pe_t2) + + if (seq_comms(ID)%iamroot) then + if (loglevel > 1) then + write(logunit,F12) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & + ' join IDs =',ID1,ID2,' npes =',seq_comms(ID)%npes, & + ' nthreads =',seq_comms(ID)%nthreads, & + ' cpl/cmp pes =',seq_comms(ID)%cplpe,seq_comms(ID)%cmppe + else + write(logunit,F13) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & + ' join IDs =',ID1,ID2,' npes =',seq_comms(ID)%npes, & + ' nthreads =',seq_comms(ID)%nthreads + endif + endif + + end subroutine seq_comm_joincomm + +!--------------------------------------------------------- + subroutine seq_comm_jcommarr(IDs,ID,iname,inst,tinst) + + implicit none + integer,intent(IN) :: IDs(:) ! src id + integer,intent(IN) :: ID ! computed id + character(len=*),intent(IN),optional :: iname ! comm name + integer,intent(IN),optional :: inst + integer,intent(IN),optional :: tinst + + integer :: mpigrp, mpigrpp + integer :: mpicom, nids + integer :: ierr + integer :: n + character(len=seq_comm_namelen) :: cname + logical :: set_suffix + character(*),parameter :: subName = '(seq_comm_jcommarr) ' + + ! check that IDs are in valid range, that IDs have + ! been set, and that ID has not been set + + nids = size(IDs) + do n = 1,nids + if (IDs(n) < 1 .or. IDs(n) > ncomps) then + write(logunit,*) subname,' IDs out of range, abort ',n,IDs(n) + call shr_sys_abort() + endif + if (.not. seq_comms(IDs(n))%set) then + write(logunit,*) subname,' IDs not set ',n,IDs(n) + call shr_sys_abort() + endif + enddo + + if (ID < 1 .or. ID > ncomps) then + write(logunit,*) subname,' ID out of range, abort ',ID + call shr_sys_abort() + endif + if (seq_comms(ID)%set) then + write(logunit,*) subname,' ID already set ',ID + call shr_sys_abort() + endif + + mpigrp = seq_comms(IDs(1))%mpigrp + do n = 1,nids + mpigrpp = mpigrp + call mpi_group_union(mpigrpp,seq_comms(IDs(n))%mpigrp,mpigrp,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_union mpigrp') + enddo + ! The allcompid is created across multiple drivers. + call mpi_comm_create(GLOBAL_COMM, mpigrp, mpicom, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_create mpigrp') + + seq_comms(ID)%set = .true. + seq_comms(ID)%ID = ID + + if (present(inst)) then + seq_comms(ID)%inst = inst + else + seq_comms(ID)%inst = 1 + endif + + set_suffix = .true. + if (present(tinst)) then + if (tinst == 1) set_suffix = .false. + endif + + if (present(iname)) then + seq_comms(ID)%name = trim(iname) + if (set_suffix) then + call seq_comm_mkname(cname,iname,seq_comms(ID)%inst) + seq_comms(ID)%name = trim(cname) + endif + endif + + if (set_suffix) then + call seq_comm_mkname(cname,'_',seq_comms(ID)%inst) + seq_comms(ID)%suffix = trim(cname) + else + seq_comms(ID)%suffix = ' ' + endif + + seq_comms(ID)%mpicom = mpicom + seq_comms(ID)%mpigrp = mpigrp + + seq_comms(ID)%nthreads = 1 + do n = 1,nids + seq_comms(ID)%nthreads = max(seq_comms(ID)%nthreads,seq_comms(IDs(n))%nthreads) + enddo + + if (mpicom /= MPI_COMM_NULL) then + call mpi_comm_size(mpicom,seq_comms(ID)%npes,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size') + call mpi_comm_rank(mpicom,seq_comms(ID)%iam,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank') + if (seq_comms(ID)%iam == 0) then + seq_comms(ID)%iamroot = .true. + else + seq_comms(ID)%iamroot = .false. + endif + else + seq_comms(ID)%npes = -1 + seq_comms(ID)%iam = -1 + seq_comms(ID)%iamroot = .false. + endif + + seq_comms(ID)%cplpe = -1 + seq_comms(ID)%cmppe = -1 + + if (seq_comms(ID)%iamroot) then + if (loglevel > 1) then + write(logunit,F14) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & + ' join multiple comp IDs',' npes =',seq_comms(ID)%npes, & + ' nthreads =',seq_comms(ID)%nthreads + else + write(logunit,F14) trim(subname),' initialize ID ',ID,seq_comms(ID)%name, & + ' join multiple comp IDs',' npes =',seq_comms(ID)%npes, & + ' nthreads =',seq_comms(ID)%nthreads + endif + endif + + end subroutine seq_comm_jcommarr + +!--------------------------------------------------------- + subroutine seq_comm_printcomms() + + implicit none + character(*),parameter :: subName = '(seq_comm_printcomms) ' + integer :: n,mype,npes,ierr + + call mpi_comm_size(DRIVER_COMM, npes , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') + call mpi_comm_rank(DRIVER_COMM, mype , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') + + call shr_sys_flush(logunit) + call mpi_barrier(DRIVER_COMM,ierr) + if (mype == 0) then + do n = 1,ncomps + write(logunit,'(a,4i6,2x,3a)') trim(subName),n, & + seq_comms(n)%gloroot,seq_comms(n)%npes,seq_comms(n)%nthreads, & + trim(seq_comms(n)%name),':',trim(seq_comms(n)%suffix) + enddo + call shr_sys_flush(logunit) + endif + + end subroutine seq_comm_printcomms + +!--------------------------------------------------------- + subroutine seq_comm_setptrs(ID,mpicom,mpigrp,npes,nthreads,iam,iamroot,gloiam,gloroot, & + cplpe,cmppe,pethreads, name) + + implicit none + integer,intent(in) :: ID + integer,intent(out),optional :: mpicom + integer,intent(out),optional :: mpigrp + integer,intent(out),optional :: npes + integer,intent(out),optional :: nthreads + integer,intent(out),optional :: iam + logical,intent(out),optional :: iamroot + integer,intent(out),optional :: gloiam + integer,intent(out),optional :: gloroot + integer,intent(out),optional :: cplpe + integer,intent(out),optional :: cmppe + integer,intent(out),optional :: pethreads + character(len=seq_comm_namelen) , intent(out), optional :: name + character(*),parameter :: subName = '(seq_comm_setptrs) ' + + ! Negative ID means there is no comm, return default or inactive values + if ((ID == 0) .or. (ID > ncomps)) then + write(logunit,*) subname,' ID out of range, return ',ID + return + endif + + if (present(mpicom)) then + if (ID > 0) then + mpicom = seq_comms(ID)%mpicom + else + mpicom = MPI_COMM_NULL + end if + endif + + if (present(mpigrp)) then + if (ID > 0) then + mpigrp = seq_comms(ID)%mpigrp + else + mpigrp = MPI_GROUP_NULL + end if + endif + + if (present(npes)) then + if (ID > 0) then + npes = seq_comms(ID)%npes + else + npes = 0 + end if + endif + + if (present(nthreads)) then + if (ID > 0) then + nthreads = seq_comms(ID)%nthreads + else + nthreads = 1 + end if + endif + + if (present(iam)) then + if (ID > 0) then + iam = seq_comms(ID)%iam + else + iam = -1 + end if + endif + + if (present(iamroot)) then + if (ID > 0) then + iamroot = seq_comms(ID)%iamroot + else + iamroot = .false. + end if + endif + + if (present(gloiam)) then + if (ID > 0) then + gloiam = seq_comms(ID)%gloiam + else + gloiam = -1 + end if + endif + + if (present(gloroot)) then + if (ID > 0) then + gloroot = seq_comms(ID)%gloroot + else + gloroot = -1 + end if + endif + + if (present(cplpe)) then + if (ID > 0) then + cplpe = seq_comms(ID)%cplpe + else + cplpe = -1 + end if + endif + + if (present(cmppe)) then + if (ID > 0) then + cmppe = seq_comms(ID)%cmppe + else + cmppe = -1 + end if + endif + + if (present(pethreads)) then + if (ID > 0) then + pethreads = seq_comms(ID)%pethreads + else + pethreads = 1 + end if + endif + + if(present(name)) then + if (ID > 0) then + name = seq_comms(ID)%name + else + name = '' + end if + end if + + end subroutine seq_comm_setptrs +!--------------------------------------------------------- + subroutine seq_comm_setnthreads(nthreads) + + implicit none + integer,intent(in) :: nthreads + character(*),parameter :: subName = '(seq_comm_setnthreads) ' + +#ifdef _OPENMP + if (nthreads < 1) then + call shr_sys_abort(subname//' ERROR: nthreads less than one') + endif + call omp_set_num_threads(nthreads) +#endif + + end subroutine seq_comm_setnthreads +!--------------------------------------------------------- + integer function seq_comm_getnthreads() + + implicit none + integer :: omp_get_num_threads + character(*),parameter :: subName = '(seq_comm_getnthreads) ' + + seq_comm_getnthreads = -1 +#ifdef _OPENMP +!$OMP PARALLEL + seq_comm_getnthreads = omp_get_num_threads() +!$OMP END PARALLEL +#endif + + end function seq_comm_getnthreads +!--------------------------------------------------------- + logical function seq_comm_iamin(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_iamin) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_iamin = .false. + else if (seq_comms(ID)%iam >= 0) then + seq_comm_iamin = .true. + else + seq_comm_iamin = .false. + endif + + end function seq_comm_iamin +!--------------------------------------------------------- + logical function seq_comm_iamroot(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_iamroot) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_iamroot = .false. + else + seq_comm_iamroot = seq_comms(ID)%iamroot + end if + + end function seq_comm_iamroot +!--------------------------------------------------------- + integer function seq_comm_mpicom(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_mpicom) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_mpicom = MPI_COMM_NULL + else + seq_comm_mpicom = seq_comms(ID)%mpicom + end if + + end function seq_comm_mpicom +!--------------------------------------------------------- + integer function seq_comm_iam(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_iam) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_iam = -1 + else + seq_comm_iam = seq_comms(ID)%iam + end if + + end function seq_comm_iam +!--------------------------------------------------------- + integer function seq_comm_gloiam(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_gloiam) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_gloiam = -1 + else + seq_comm_gloiam = seq_comms(ID)%gloiam + end if + + end function seq_comm_gloiam +!--------------------------------------------------------- + integer function seq_comm_gloroot(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_gloroot) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_gloroot = -1 + else + seq_comm_gloroot = seq_comms(ID)%gloroot + end if + + end function seq_comm_gloroot +!--------------------------------------------------------- + integer function seq_comm_cplpe(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_cplpe) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_cplpe = -1 + else + seq_comm_cplpe = seq_comms(ID)%cplpe + end if + + end function seq_comm_cplpe +!--------------------------------------------------------- + integer function seq_comm_cmppe(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_cmppe) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_cmppe = -1 + else + seq_comm_cmppe = seq_comms(ID)%cmppe + end if + + end function seq_comm_cmppe +!--------------------------------------------------------- + character(len=seq_comm_namelen) function seq_comm_name(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_name) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_name = '' + else + seq_comm_name = trim(seq_comms(ID)%name) + end if + + end function seq_comm_name +!--------------------------------------------------------- + character(len=seq_comm_namelen) function seq_comm_suffix(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_suffix) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_suffix = '' + else + seq_comm_suffix = trim(seq_comms(ID)%suffix) + end if + + end function seq_comm_suffix +!--------------------------------------------------------- +!--------------------------------------------------------- + integer function seq_comm_inst(ID) + + implicit none + integer,intent(in) :: ID + character(*),parameter :: subName = '(seq_comm_inst) ' + + if ((ID < 1) .or. (ID > ncomps)) then + seq_comm_inst = 0 + else + seq_comm_inst = seq_comms(ID)%inst + end if + + end function seq_comm_inst +!--------------------------------------------------------- + subroutine seq_comm_mkname(oname,str1,num) + implicit none + character(len=*),intent(out) :: oname + character(len=*),intent(in) :: str1 + integer,intent(in) :: num + character(*),parameter :: subName = '(seq_comm_mkname) ' + + character(len=8) :: cnum + + write(cnum,'(i4.4)') num + if (len_trim(str1) + len_trim(cnum) > len(oname)) then + write(logunit,*) trim(subname),' ERROR in str lens ',len(oname),trim(str1),trim(cnum) + call shr_sys_abort(trim(subname)) + endif + oname = trim(str1)//trim(cnum) + + end subroutine seq_comm_mkname +!--------------------------------------------------------- +end module seq_comm_mct diff --git a/driver-mct/shr/seq_drydep_mod.F90 b/driver-mct/shr/seq_drydep_mod.F90 new file mode 100644 index 000000000000..03e877a371fd --- /dev/null +++ b/driver-mct/shr/seq_drydep_mod.F90 @@ -0,0 +1,913 @@ +module seq_drydep_mod + + !======================================================================== + ! Module for handling dry depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + ! + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - creation. + ! 2009-Feb-19 - E. Kluzek - merge shr_drydep_tables module in. + ! 2009-Feb-20 - E. Kluzek - use shr_ coding standards, and check for namelist file. + ! 2009-Feb-20 - E. Kluzek - Put _r8 on all constants, remove namelist read out. + ! 2009-Mar-23 - F. Vitt - Some corrections/cleanup and addition of drydep_method. + ! 2009-Mar-27 - E. Kluzek - Get description and units from J.F. Lamarque. + !======================================================================== + + ! !USES: + + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_kind_mod, only : r8 => shr_kind_r8, CS => SHR_KIND_CS, CX => SHR_KIND_CX + use shr_const_mod, only : SHR_CONST_G, SHR_CONST_RDAIR, & + SHR_CONST_CPDAIR, SHR_CONST_MWWV + + implicit none + save + + private + + ! !PUBLIC MEMBER FUNCTIONS + + public :: seq_drydep_readnl ! Read namelist + public :: seq_drydep_init ! Initialization of drydep data + public :: seq_drydep_setHCoeff ! Calculate Henry's law coefficients + + ! !PRIVATE ARRAY SIZES + + integer, private, parameter :: maxspc = 100 ! Maximum number of species + integer, public, parameter :: n_species_table = 77 ! Number of species to work with + integer, private, parameter :: NSeas = 5 ! Number of seasons + integer, private, parameter :: NLUse = 11 ! Number of land-use types + + ! !PUBLIC DATA MEMBERS: + + ! method specification + character(16),public,parameter :: DD_XATM = 'xactive_atm'! dry-dep atmosphere + character(16),public,parameter :: DD_XLND = 'xactive_lnd'! dry-dep land + character(16),public,parameter :: DD_TABL = 'table' ! dry-dep table (atm and lnd) + character(16),public :: drydep_method = DD_XLND ! Which option choosen + + real(r8), public, parameter :: ph = 1.e-5_r8 ! measure of the acidity (dimensionless) + + logical, public :: lnd_drydep ! If dry-dep fields passed + integer, public :: n_drydep = 0 ! Number in drypdep list + character(len=32), public, dimension(maxspc) :: drydep_list = '' ! List of dry-dep species + + character(len=CS), public :: drydep_fields_token = '' ! First drydep fields token + + real(r8), public, allocatable, dimension(:) :: foxd ! reactivity factor for oxidation (dimensioness) + real(r8), public, allocatable, dimension(:) :: drat ! ratio of molecular diffusivity (D_H2O/D_species; dimensionless) + integer, public, allocatable, dimension(:) :: mapping ! mapping to species table + ! --- Indices for each species --- + integer, public :: h2_ndx, ch4_ndx, co_ndx, pan_ndx, mpan_ndx, so2_ndx, o3_ndx, o3a_ndx, xpan_ndx + + !--------------------------------------------------------------------------- + ! Table 1 from Wesely, Atmos. Environment, 1989, p1293 + ! Table 2 from Sheih, microfiche PB86-218104 and Walcek, Atmos. Environment, 1986, p949 + ! Table 3-5 compiled by P. Hess + ! + ! index #1 : 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 + ! + ! index #2 : landuse type + ! 1 -> urban land + ! 2 -> agricultural land + ! 3 -> range land + ! 4 -> deciduous forest + ! 5 -> coniferous forest + ! 6 -> mixed forest including wetland + ! 7 -> water, both salt and fresh + ! 8 -> barren land, mostly desert + ! 9 -> nonforested wetland + ! 10 -> mixed agricultural and range land + ! 11 -> rocky open areas with low growing shrubs + ! + ! JFL August 2000 + !--------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! table to parameterize the impact of soil moisture on the deposition of H2 and + ! CO on soils (from Sanderson et al., J. Atmos. Chem., 46, 15-28, 2003). + !--------------------------------------------------------------------------- + + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_a(NLUse) = & + (/ 0.000_r8, 0.000_r8, 0.270_r8, 0.000_r8, 0.000_r8, & + 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_b(NLUse) = & + (/ 0.000_r8,-41.390_r8, -0.472_r8,-41.900_r8,-41.900_r8, & + -41.900_r8, 0.000_r8, 0.000_r8, 0.000_r8,-41.390_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_c(NLUse) = & + (/ 0.000_r8, 16.850_r8, 1.235_r8, 19.700_r8, 19.700_r8, & + 19.700_r8, 0.000_r8, 0.000_r8, 0.000_r8, 17.700_r8, 1.000_r8/) + + !--- deposition of h2 and CO on soils + ! + !--- ri: Richardson number (dimensionless) + !--- rlu: Resistance of leaves in upper canopy (s.m-1) + !--- rac: Aerodynamic resistance to lower canopy (s.m-1) + !--- rgss: Ground surface resistance for SO2 (s.m-1) + !--- rgso: Ground surface resistance for O3 (s.m-1) + !--- rcls: Lower canopy resistance for SO2 (s.m-1) + !--- rclo: Lower canopy resistance for O3 (s.m-1) + ! + real(r8), public, dimension(NSeas,NLUse) :: ri, rlu, rac, rgss, rgso, rcls, rclo + + data ri (1,1:NLUse) & + /1.e36_r8, 60._r8, 120._r8, 70._r8, 130._r8, 100._r8,1.e36_r8,1.e36_r8, 80._r8, 100._r8, 150._r8/ + data rlu (1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rac (1,1:NLUse) & + / 100._r8, 200._r8, 100._r8,2000._r8,2000._r8,2000._r8, 0._r8, 0._r8, 300._r8, 150._r8, 200._r8/ + data rgss(1,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 220._r8, 400._r8/ + data rgso(1,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rclo(1,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8,1000._r8,1000._r8,1000._r8,1.e36_r8,1.e36_r8,1000._r8,1000._r8,1000._r8/ + + data ri (2,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (2,1:NLUse) & + / 100._r8, 150._r8, 100._r8,1500._r8,2000._r8,1700._r8, 0._r8, 0._r8, 200._r8, 120._r8, 140._r8/ + data rgss(2,1:NLUse) & + / 400._r8, 200._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 300._r8, 400._r8/ + data rgso(2,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8, 800._r8, 180._r8, 200._r8/ + data rcls(2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,2000._r8,4000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(2,1:NLUse) & + /1.e36_r8, 400._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 400._r8, 400._r8, 400._r8/ + + data ri (3,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (3,1:NLUse) & + / 100._r8, 10._r8, 100._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 100._r8, 50._r8, 120._r8/ + data rgss(3,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 200._r8, 400._r8/ + data rgso(3,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,3000._r8,6000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(3,1:NLUse) & + /1.e36_r8,1000._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8, 600._r8, 600._r8/ + + data ri (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 400._r8, 800._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,6000._r8,9000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (4,1:NLUse) & + / 100._r8, 10._r8, 10._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 50._r8, 10._r8, 50._r8/ + data rgss(4,1:NLUse) & + / 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 0._r8,1000._r8, 100._r8, 100._r8, 50._r8/ + data rgso(4,1:NLUse) & + / 600._r8,3500._r8,3500._r8,3500._r8,3500._r8,3500._r8,2000._r8, 400._r8,3500._r8,3500._r8,3500._r8/ + data rcls(4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,9000._r8, 200._r8, 400._r8,1.e36_r8,1.e36_r8,9000._r8,1.e36_r8,9000._r8/ + data rclo(4,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8, 400._r8,1500._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8,1000._r8, 800._r8/ + + data ri (5,1:NLUse) & + /1.e36_r8, 120._r8, 240._r8, 140._r8, 250._r8, 190._r8,1.e36_r8,1.e36_r8, 160._r8, 200._r8, 300._r8/ + data rlu (5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rac (5,1:NLUse) & + / 100._r8, 50._r8, 80._r8,1200._r8,2000._r8,1500._r8, 0._r8, 0._r8, 200._r8, 60._r8, 120._r8/ + data rgss(5,1:NLUse) & + / 500._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 250._r8, 400._r8/ + data rgso(5,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rclo(5,1:NLUse) & + /1.e36_r8,1000._r8, 500._r8, 500._r8,1500._r8, 700._r8,1.e36_r8,1.e36_r8, 600._r8, 800._r8, 800._r8/ + + !--------------------------------------------------------------------------- + ! ... roughness length + !--------------------------------------------------------------------------- + real(r8), public, dimension(NSeas,NLUse) :: z0 + + data z0 (1,1:NLUse) & + /1.000_r8,0.250_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.150_r8,0.100_r8,0.100_r8/ + data z0 (2,1:NLUse) & + /1.000_r8,0.100_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.080_r8,0.080_r8/ + data z0 (3,1:NLUse) & + /1.000_r8,0.005_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.020_r8,0.060_r8/ + data z0 (4,1:NLUse) & + /1.000_r8,0.001_r8,0.001_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.001_r8,0.001_r8,0.040_r8/ + data z0 (5,1:NLUse) & + /1.000_r8,0.030_r8,0.020_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.010_r8,0.030_r8,0.060_r8/ + + !real(r8), private, dimension(11,5), parameter :: z0xxx = reshape ( & + ! (/ 1.000,0.250,0.050,1.000,1.000,1.000,0.0006,0.002,0.150,0.100,0.100 , & + ! 1.000,0.100,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.080,0.080 , & + ! 1.000,0.005,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.020,0.060 , & + ! 1.000,0.001,0.001,1.000,1.000,1.000,0.0006,0.002,0.001,0.001,0.040 , & + ! 1.000,0.030,0.020,1.000,1.000,1.000,0.0006,0.002,0.010,0.030,0.060 /), (/11,5/) ) + + !--------------------------------------------------------------------------- + ! public chemical data + !--------------------------------------------------------------------------- + + !--- data for foxd (reactivity factor for oxidation) ---- + real(r8), public, parameter :: dfoxd(n_species_table) = & + (/ 1._r8 & + ,1._r8 & + ,1._r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1._r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,0._r8 & + ,0._r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1._r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1._r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,.1_r8 & + ,.1_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,.1_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & + ,.1_r8 & + ,.1_r8 & + ,.1_r8 & + ,1.e-36_r8 & + ,1.e-36_r8 & ! HCN + ,1.e-36_r8 & ! CH3CN + ,1.e-36_r8 & ! SO2 + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + ,0.1_r8 & + /) + + ! PRIVATE DATA: + + Interface seq_drydep_setHCoeff ! overload subroutine + Module Procedure set_hcoeff_scalar + Module Procedure set_hcoeff_vector + End Interface + + real(r8), private, parameter :: small_value = 1.e-36_r8 !--- smallest value to use --- + + !--------------------------------------------------------------------------- + ! private chemical data + !--------------------------------------------------------------------------- + + !--- Names of species that can work with --- + character(len=20), public, parameter :: species_name_table(n_species_table) = & + (/ 'OX ' & + ,'H2O2 ' & + ,'OH ' & + ,'HO2 ' & + ,'CO ' & + ,'CH4 ' & + ,'CH3O2 ' & + ,'CH3OOH ' & + ,'CH2O ' & + ,'CHOOH ' & + ,'NO ' & + ,'NO2 ' & + ,'HNO3 ' & + ,'CO2 ' & + ,'NH3 ' & + ,'N2O5 ' & + ,'NO3 ' & + ,'CH3OH ' & + ,'HO2NO2 ' & + ,'O1D ' & + ,'C2H6 ' & + ,'C2H5O2 ' & + ,'PO2 ' & + ,'MACRO2 ' & + ,'ISOPO2 ' & + ,'C4H10 ' & + ,'CH3CHO ' & + ,'C2H5OOH ' & + ,'C3H6 ' & + ,'POOH ' & + ,'C2H4 ' & + ,'PAN ' & + ,'CH3COOOH' & + ,'C10H16 ' & + ,'CHOCHO ' & + ,'CH3COCHO' & + ,'GLYALD ' & + ,'CH3CO3 ' & + ,'C3H8 ' & + ,'C3H7O2 ' & + ,'CH3COCH3' & + ,'C3H7OOH ' & + ,'RO2 ' & + ,'ROOH ' & + ,'Rn ' & + ,'ISOP ' & + ,'MVK ' & + ,'MACR ' & + ,'C2H5OH ' & + ,'ONITR ' & + ,'ONIT ' & + ,'ISOPNO3 ' & + ,'HYDRALD ' & + ,'HCN ' & + ,'CH3CN ' & + ,'SO2 ' & + ,'SOAGff0 ' & + ,'SOAGff1 ' & + ,'SOAGff2 ' & + ,'SOAGff3 ' & + ,'SOAGff4 ' & + ,'SOAGbg0 ' & + ,'SOAGbg1 ' & + ,'SOAGbg2 ' & + ,'SOAGbg3 ' & + ,'SOAGbg4 ' & + ,'SOAG0 ' & + ,'SOAG1 ' & + ,'SOAG2 ' & + ,'SOAG3 ' & + ,'SOAG4 ' & + ,'IVOC ' & + ,'SVOC ' & + ,'IVOCbb ' & + ,'IVOCff ' & + ,'SVOCbb ' & + ,'SVOCff ' & + /) + + !--- data for effective Henry's Law coefficient --- + real(r8), public, parameter :: dheff(n_species_table*6) = & + (/1.15e-02_r8, 2560._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,8.33e+04_r8, 7379._r8,2.2e-12_r8,-3730._r8,0._r8 , 0._r8 & + ,3.00e+01_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,2.00e+03_r8, 6600._r8,3.5e-05_r8, 0._r8,0._r8 , 0._r8 & + ,1.00e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.11e+02_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,6.30e+03_r8, 6425._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,5.53e+03_r8, 5700._r8,1.8e-04_r8,-1510._r8,0._r8 , 0._r8 & + ,1.90e-03_r8, 1480._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,6.40e-03_r8, 2500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,0._r8 , 0._r8,2.6e+06_r8, 8700._r8,0._r8 , 0._r8 & + ,3.40e-02_r8, 2420._r8,4.5e-07_r8,-1000._r8,3.6e-11_r8,-1760._r8 & + ,7.40e+01_r8, 3400._r8,1.7e-05_r8, -450._r8,1.0e-14_r8,-6716._r8 & + ,2.14e+00_r8, 3362._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,0.65e+00_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,2.20e+02_r8, 4934._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,0._r8 , 0._r8,3.2e+01_r8, 0._r8,0._r8 , 0._r8 & + ,1.00e-16_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.14e+01_r8, 6267._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,2.20e+02_r8, 5653._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,5.00e+00_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,8.37e+02_r8, 5308._r8,1.8e-04_r8,-1510._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.00e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.71e+03_r8, 7541._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,4.14e+04_r8, 4630._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.45e-03_r8, 2700._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.00e+06_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,2.70e+01_r8, 5300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.47e+00_r8, 5241._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,0.00e+00_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,2.00e+02_r8, 6500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.51e+03_r8, 6485._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.00e+03_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.00e+01_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.00e+01_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.20e+01_r8, 5000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,5.00e+01_r8, 4000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.23e+00_r8, 3120._r8,1.23e-02_r8,1960._r8,0._r8 , 0._r8 & + ,1.3e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.2e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,4.0e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.3e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.6e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,7.9e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,6.3e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.2e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,6.3e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.2e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,4.0e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.2e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.6e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,3.2e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.6e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & + /) + + real(r8), private, parameter :: wh2o = SHR_CONST_MWWV + real(r8), private, parameter :: mol_wgts(n_species_table) = & + (/ 47.9981995_r8, 34.0135994_r8, 17.0067997_r8, 33.0061989_r8, 28.0104008_r8, & + 16.0405998_r8, 47.0320015_r8, 48.0393982_r8, 30.0251999_r8, 46.0246010_r8, & + 30.0061398_r8, 46.0055389_r8, 63.0123405_r8, 44.0098000_r8, 17.0289402_r8, & + 108.010483_r8, 62.0049400_r8, 32.0400009_r8, 79.0117416_r8, 15.9994001_r8, & + 30.0664005_r8, 61.0578003_r8, 91.0830002_r8, 119.093399_r8, 117.119797_r8, & + 58.1180000_r8, 44.0509987_r8, 62.0652008_r8, 42.0774002_r8, 92.0904007_r8, & + 28.0515995_r8, 121.047943_r8, 76.0497971_r8, 136.228394_r8, 58.0355988_r8, & + 72.0614014_r8, 60.0503998_r8, 75.0423965_r8, 44.0922012_r8, 75.0836029_r8, & + 58.0768013_r8, 76.0910034_r8, 31.9988003_r8, 33.0061989_r8, 222.000000_r8, & + 68.1141968_r8, 70.0877991_r8, 70.0877991_r8, 46.0657997_r8, 147.125946_r8, & + 119.074341_r8, 162.117935_r8, 100.112999_r8, 27.0256_r8 , 41.0524_r8 , & + 64.064800_r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 170.3_r8, 170.3_r8, 170.3_r8, 170.3_r8, & + 170.3_r8, 170.3_r8 /) + + +!=============================================================================== +CONTAINS +!=============================================================================== + +!==================================================================================== + + subroutine seq_drydep_readnl(NLFilename, ID, seq_drydep_fields) + + !======================================================================== + ! reads drydep_inparm namelist and sets up CCSM driver list of fields for + ! land-atmosphere communications. + ! + ! !REVISION HISTORY: + ! 2009-Feb-20 - E. Kluzek - Separate out as subroutine from previous input_init + !======================================================================== + + use shr_file_mod,only : shr_file_getUnit, shr_file_freeUnit + use shr_log_mod, only : s_logunit => shr_log_Unit + use seq_comm_mct,only : seq_comm_iamroot, seq_comm_setptrs + use shr_mpi_mod, only : shr_mpi_bcast + use shr_nl_mod, only : shr_nl_find_group_name + implicit none + + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer , intent(in) :: ID ! seq_comm ID + character(len=*), intent(out) :: seq_drydep_fields + + !----- local ----- + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + character(len=8) :: token ! dry dep field name to add + integer :: mpicom ! MPI communicator + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_read) ' + character(*),parameter :: F00 = "('(seq_drydep_read) ',8a)" + character(*),parameter :: FI1 = "('(seq_drydep_init) ',a,I2)" + + namelist /drydep_inparm/ drydep_list, drydep_method + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the drydep field list to pass + ! First check if file exists and if not, n_drydep will be zero + !----------------------------------------------------------------------------- + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 )then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + call seq_comm_setptrs(ID,mpicom=mpicom) + if (seq_comm_iamroot(ID)) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + unitn = shr_file_getUnit() + open( unitn, file=trim(NLFilename), status='old' ) + if ( s_loglev > 0 ) write(s_logunit,F00) & + 'Read in drydep_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'drydep_inparm', ierr) + if (ierr == 0) then + ierr = 1 + do while ( ierr /= 0 ) + read(unitn, drydep_inparm, iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subName//'ERROR: encountered end-of-file on namelist read' ) + endif + end do + else + write(s_logunit,*) 'seq_drydep_read: no drydep_inparm namelist found in ',NLFilename + endif + close( unitn ) + call shr_file_freeUnit( unitn ) + end if + end if + call shr_mpi_bcast( drydep_list, mpicom ) + call shr_mpi_bcast( drydep_method, mpicom ) + + n_drydep = 0 + + !--- Loop over species to fill list of fields to communicate for drydep --- + seq_drydep_fields = ' ' + do i=1,maxspc + if ( len_trim(drydep_list(i))==0 ) exit + write(token,333) i + seq_drydep_fields = trim(seq_drydep_fields)//':'//trim(token) + if ( i == 1 ) then + seq_drydep_fields = trim(token) + drydep_fields_token = trim(token) + endif + n_drydep = n_drydep+1 + enddo + + !--- Make sure method is valid and determine if land is passing drydep fields --- + lnd_drydep = n_drydep>0 .and. drydep_method == DD_XLND + + if ( s_loglev > 0 ) then + write(s_logunit,*) 'seq_drydep_read: drydep_method: ', trim(drydep_method) + if ( n_drydep == 0 )then + write(s_logunit,F00) 'No dry deposition fields will be transfered' + else + write(s_logunit,FI1) 'Number of dry deposition fields transfered is ', & + n_drydep + end if + end if + + if ( trim(drydep_method)/=trim(DD_XATM) .and. & + trim(drydep_method)/=trim(DD_XLND) .and. & + trim(drydep_method)/=trim(DD_TABL) ) then + if ( s_loglev > 0 ) then + write(s_logunit,*) 'seq_drydep_read: drydep_method : ', trim(drydep_method) + write(s_logunit,*) 'seq_drydep_read: drydep_method must be set to : ', & + DD_XATM,', ', DD_XLND,', or ', DD_TABL + end if + call shr_sys_abort('seq_drydep_read: incorrect dry deposition method specification') + endif + + ! Need to explicitly add Sl_ based on naming convention +333 format ('Sl_dd',i3.3) + + end subroutine seq_drydep_readnl + +!==================================================================================== + + subroutine seq_drydep_init( ) + + !======================================================================== + ! Initialization of dry deposition fields + ! reads drydep_inparm namelist and sets up CCSM driver list of fields for + ! land-atmosphere communications. + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - first version + ! 2009-Feb-20 - E. Kluzek - Check for existance of file if not return, set n_drydep=0 + ! 2009-Feb-20 - E. Kluzek - Move namelist read to separate subroutine + !======================================================================== + + use shr_log_mod, only : s_logunit => shr_log_Unit + use shr_infnan_mod, only: shr_infnan_posinf, assignment(=) + + implicit none + + !----- local ----- + integer :: i, l ! Indices + character(len=32) :: test_name ! field test name + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_init) ' + character(*),parameter :: F00 = "('(seq_drydep_init) ',8a)" + + !----------------------------------------------------------------------------- + ! Allocate and fill foxd, drat and mapping as well as species indices + !----------------------------------------------------------------------------- + + if ( n_drydep > 0 ) then + + allocate( foxd(n_drydep) ) + allocate( drat(n_drydep) ) + allocate( mapping(n_drydep) ) + + ! This initializes these variables to infinity. + foxd = shr_infnan_posinf + drat = shr_infnan_posinf + + mapping(:) = 0 + + end if + + h2_ndx=-1; ch4_ndx=-1; co_ndx=-1; mpan_ndx = -1; pan_ndx = -1; so2_ndx=-1; o3_ndx=-1; xpan_ndx=-1 + + !--- Loop over drydep species that need to be worked with --- + do i=1,n_drydep + if ( len_trim(drydep_list(i))==0 ) exit + + test_name = drydep_list(i) + + if( trim(test_name) == 'O3' ) then + test_name = 'OX' + end if + + !--- Figure out if species maps to a species in the species table --- + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + + !--- If it doesn't map to a species in the species table find species close enough --- + if( mapping(i) < 1 ) then + select case( trim(test_name) ) + case( 'H2' ) + test_name = 'CO' + case( 'HYAC', 'CH3COOH', 'EOOH', 'IEPOX' ) + test_name = 'CH2O' + case( 'O3S', 'O3INERT', 'MPAN' ) + test_name = 'OX' + case( 'ISOPOOH', 'MACROOH', 'Pb', 'XOOH', 'H2SO4' ) + test_name = 'HNO3' + case( 'ALKOOH', 'MEKOOH', 'TOLOOH', 'BENOOH', 'XYLOOH', 'SOGM','SOGI','SOGT','SOGB','SOGX' ) + test_name = 'CH3OOH' + case( 'SOA', 'SO4', 'CB1', 'CB2', 'OC1', 'OC2', 'NH3', 'NH4', 'SA1', 'SA2', 'SA3', 'SA4','HCN','CH3CN','HCOOH' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAM', 'SOAI', 'SOAT', 'SOAB', 'SOAX' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAGbb0' ) + test_name = 'SOAGff0' + case( 'SOAGbb1' ) + test_name = 'SOAGff1' + case( 'SOAGbb2' ) + test_name = 'SOAGff2' + case( 'SOAGbb3' ) + test_name = 'SOAGff3' + case( 'SOAGbb4' ) + test_name = 'SOAGff4' + case( 'NOA', 'ALKNIT', 'ISOPNITA', 'ISOPNITB', 'HONITR', 'ISOPNOOH', 'NC4CHO', 'NC4CH2OH', 'TERPNIT', 'NTERPOOH' ) + test_name = 'H2O2' + case( 'PHENOOH', 'BENZOOH', 'C6H5OOH', 'BZOOH', 'XYLOLOOH', 'XYLENOOH', 'HPALD' ) + test_name = 'CH3OOH' + case( 'TERPOOH', 'TERP2OOH', 'MBOOOH' ) + test_name = 'HNO3' + case( 'TERPROD1', 'TERPROD2' ) + test_name = 'CH2O' + case( 'HMPROP' ) + test_name = 'GLYALD' + case( 'O3A', 'XMPAN' ) + test_name = 'OX' + case( 'XPAN' ) + test_name = 'PAN' + case( 'XNO' ) + test_name = 'NO' + case( 'XNO2' ) + test_name = 'NO2' + case( 'XHNO3' ) + test_name = 'HNO3' + case( 'XONIT' ) + test_name = 'ONIT' + case( 'XONITR' ) + test_name = 'ONITR' + case( 'XHO2NO2') + test_name = 'HO2NO2' + case( 'XNH4NO3' ) + test_name = 'HNO3' + case( 'COhc','COme') + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'CO01','CO02','CO03','CO04','CO05','CO06','CO07','CO08','CO09','CO10' ) + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'CO11','CO12','CO13','CO14','CO15','CO16','CO17','CO18','CO19','CO20' ) + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'CO21','CO22','CO23','CO24','CO25','CO26','CO27','CO28','CO29','CO30' ) + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'CO31','CO32','CO33','CO34','CO35','CO36','CO37','CO38','CO39','CO40' ) + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'CO41','CO42','CO43','CO44','CO45','CO46','CO47','CO48','CO49','CO50' ) + test_name = 'CO' ! this is just a place holder. values are set in drydep_fromlnd + case( 'NH4NO3' ) + test_name = 'HNO3' + case default + test_name = 'blank' + end select + + !--- If found a match check the species table again --- + if( trim(test_name) /= 'blank' ) then + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + else + if ( s_loglev > 0 ) write(s_logunit,F00) trim(drydep_list(i)), & + ' not in tables; will have dep vel = 0' + call shr_sys_abort( subName//': '//trim(drydep_list(i))//' is not in tables' ) + end if + end if + + !--- Figure out the specific species indices --- + if ( trim(drydep_list(i)) == 'H2' ) h2_ndx = i + if ( trim(drydep_list(i)) == 'CO' ) co_ndx = i + if ( trim(drydep_list(i)) == 'CH4' ) ch4_ndx = i + if ( trim(drydep_list(i)) == 'MPAN' ) mpan_ndx = i + if ( trim(drydep_list(i)) == 'PAN' ) pan_ndx = i + if ( trim(drydep_list(i)) == 'SO2' ) so2_ndx = i + if ( trim(drydep_list(i)) == 'OX' .or. trim(drydep_list(i)) == 'O3' ) o3_ndx = i + if ( trim(drydep_list(i)) == 'O3A' ) o3a_ndx = i + if ( trim(drydep_list(i)) == 'XPAN' ) xpan_ndx = i + + if( mapping(i) > 0) then + l = mapping(i) + foxd(i) = dfoxd(l) + drat(i) = sqrt(mol_wgts(l)/wh2o) + endif + + enddo + + where( rgss < 1._r8 ) + rgss = 1._r8 + endwhere + + where( rac < small_value) + rac = small_value + endwhere + + end subroutine seq_drydep_init + +!==================================================================================== + + subroutine set_hcoeff_scalar( sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is scalar + ! wrapper routine used when surface temperature is a scalar (single column) rather + ! than an array (multiple columns). + ! + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - first version + !======================================================================== + + implicit none + + real(r8), intent(in) :: sfc_temp ! Input surface temperature + real(r8), intent(out) :: heff(n_drydep) ! Output Henry's law coefficients + + !----- local ----- + real(r8) :: sfc_temp_tmp(1) ! surface temp + + sfc_temp_tmp(:) = sfc_temp + call set_hcoeff_vector( 1, sfc_temp_tmp, heff(:n_drydep) ) + + end subroutine set_hcoeff_scalar + +!==================================================================================== + + subroutine set_hcoeff_vector( ncol, sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is vector + ! sets dry depositions coefficients -- used by both land and atmosphere models + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - first version + !======================================================================== + + use shr_log_mod, only : s_logunit => shr_log_Unit + + implicit none + + integer, intent(in) :: ncol ! Input size of surface-temp vector + real(r8), intent(in) :: sfc_temp(ncol) ! Surface temperature + real(r8), intent(out) :: heff(ncol,n_drydep) ! Henry's law coefficients + + !----- local ----- + real(r8), parameter :: t0 = 298._r8 ! Standard Temperature + real(r8), parameter :: ph_inv = 1._r8/ph ! Inverse of PH + integer :: m, l, id ! indices + real(r8) :: e298 ! Henry's law coefficient @ standard temperature (298K) + real(r8) :: dhr ! temperature dependence of Henry's law coefficient + real(r8) :: dk1s(ncol) ! DK Work array 1 + real(r8) :: dk2s(ncol) ! DK Work array 2 + real(r8) :: wrk(ncol) ! Work array + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_set_hcoeff) ' + character(*),parameter :: F00 = "('(seq_drydep_set_hcoeff) ',8a)" + + !------------------------------------------------------------------------------- + ! notes: + !------------------------------------------------------------------------------- + + wrk(:) = (t0 - sfc_temp(:))/(t0*sfc_temp(:)) + do m = 1,n_drydep + l = mapping(m) + id = 6*(l - 1) + e298 = dheff(id+1) + dhr = dheff(id+2) + heff(:,m) = e298*exp( dhr*wrk(:) ) + !--- Calculate coefficients based on the drydep tables --- + if( dheff(id+3) /= 0._r8 .and. dheff(id+5) == 0._r8 ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + where( heff(:,m) /= 0._r8 ) + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv) + elsewhere + heff(:,m) = dk1s(:)*ph_inv + endwhere + end if + !--- For coefficients that are non-zero AND CO2 or NH3 handle things this way --- + if( dheff(id+5) /= 0._r8 ) then + if( trim( drydep_list(m) ) == 'CO2' .or. trim( drydep_list(m) ) == 'NH3' ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + e298 = dheff(id+5) + dhr = dheff(id+6) + dk2s(:) = e298*exp( dhr*wrk(:) ) + !--- For Carbon dioxide --- + if( trim(drydep_list(m)) == 'CO2' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv)*(1._r8 + dk2s(:)*ph_inv) + !--- For NH3 --- + else if( trim( drydep_list(m) ) == 'NH3' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph/dk2s(:)) + !--- This can't happen --- + else + write(s_logunit,F00) 'Bad species ',drydep_list(m) + call shr_sys_abort( subName//'ERROR: in assigning coefficients' ) + end if + end if + end if + end do + + end subroutine set_hcoeff_vector + +!=============================================================================== + +end module seq_drydep_mod diff --git a/driver-mct/shr/seq_flds_mod.F90 b/driver-mct/shr/seq_flds_mod.F90 new file mode 100644 index 000000000000..d484afcbba34 --- /dev/null +++ b/driver-mct/shr/seq_flds_mod.F90 @@ -0,0 +1,3613 @@ +module seq_flds_mod + + !==================================================================== + ! New standardized naming convention + !==================================================================== + ! + ! --------- + ! definitions: + ! --------- + ! state-prefix + ! first 3 characters: Sx_, Sa_, Si_, Sl_, So_ + ! one letter indices: x,a,l,i,o,g,r + ! x => coupler (mapping, merging, atm/ocn flux calc done on coupler procs) + ! a => atm + ! l => lnd + ! i => ice + ! o => ocn + ! g => glc + ! r => rof + ! w => wav + ! + ! state-name + ! what follows state prefix + ! + ! flux-prefix + ! first 5 characters: Flmn__ + ! lm => between components l and m + ! n => computed by component n + ! example: Fioi => ice/ocn flux computed by ice + ! example: Fall => atm/lnd flux computed by lnd + ! If flux prefix has first letter of P (so first five characters are PFlmn_) + ! then flux is passed straight through without scaling by the corresponding fraction) + ! + ! flux-name + ! what follows flux-prefix + ! + ! --------- + ! rules: + ! --------- + ! 1) states: + ! a) atm attributes fields that HAVE a state-prefix of Sx_ in seq_flds_x2a_states + ! rule: will merge all identical values of the state-names from + ! seq_flds_i2x_states + ! seq_flds_l2x_states + ! seq_flds_o2x_states + ! seq_flds_xao_states + ! to obtain output state-name in seq_flds_x2a_states + ! + ! rule: to merge input states that originate in the + ! lnd (l2x_a) will be scaled by the lndfrac + ! ice (i2x_a) will be scaled by the icefrac + ! cpl (xao_a) will be scaled by the ocnfrac + ! ocn (o2x_a) will be scaled by the ocnfrac + ! + ! example: + ! seq_flds_l2x_states = "Sl_t" + ! seq_flds_i2x_states = "Si_t" + ! seq_flds_o2x_states = "So_t" + ! seq_flds_x2a_states = "Sx_t" + ! attribute fields Sl_t, Si_t, So_t, in + ! attribute vectors l2x_a, i2x_a, o2x_a will be + ! merged to obtain attribute Sx_t in attribute vector x2a_a + ! + ! b) atm attribute fields that DO NOT HAVE a state-prefix of Sx_ in seq_flds_x2a_states + ! rule: copy directly all variables that identical state-prefix + ! AND state-name in + ! seq_flds_i2x_states and seq_flds_x2a_states + ! seq_flds_l2x_states and seq_flds_x2a_states + ! seq_flds_o2x_states and seq_flds_x2a_states + ! seq_flds_xao_states and seq_flds_x2a_states + ! + ! example + ! seq_flds_i2x_states = ":Si_snowh" + ! seq_flds_x2a_states = ":Si_snowh" + ! attribute field of Si_snowh in i2x_a will be copied to + ! attribute field Si_snowh in x2a_a + ! + ! 2) fluxes: + ! rule: will merge all identical values of the flux-names from + ! seq_flds_i2x_states + ! seq_flds_l2x_states + ! seq_flds_o2x_states + ! seq_flds_xao_states + ! to obtain output state-name in seq_flds_x2a_states + ! + ! rule: input flux fields that originate in the + ! lnd (l2x_a) will be scaled by the lndfrac + ! ice (i2x_a) will be scaled by the icefrac + ! - ignore all fluxes that are ice/ocn fluxes (e.g. Fioi_) + ! cpl (xao_a) will be scaled by the ocnfrac + ! ocn (o2x_a) will be scaled by the ocnfrac+icefrac + ! + !==================================================================== + ! + ! New user specified fields + ! + !==================================================================== + ! New fields that are user specidied can be added as namelist variables + ! by the user in the cpl namelist seq_flds_user using the namelist variable + ! array cplflds_customs. The user specified new fields must follow the + ! above naming convention. + ! As an example, say you want to add a new state 'foo' that is passed + ! from the land to the atm - you would do this as follows + ! &seq_flds_user + ! cplflds_custom = 'Sa_foo->a2x', 'Sa_foo->x2a' + ! / + ! This would add the field 'Sa_foo' to the character strings defining the + ! attribute vectors a2x and x2a. It is assumed that code would need to be + ! introduced in the atm and land components to deal with this new attribute + ! vector field. + ! Currently, the only way to add this is to edit $CASEROOT/user_nl_cpl + !==================================================================== + ! + ! Coupler fields use cases + ! + !==================================================================== + ! Previously, new fields that were needed to be passed between components + ! for certain compsets were specified by cpp-variables. This has been + ! modified to now be use cases. The use cases are specified in the + ! namelist cpl_flds_inparm and are currently triggered by the xml + ! variables CCSM_VOC, CCSM_BGC and GLC_NEC. + !==================================================================== + + use shr_kind_mod , only : CX => shr_kind_CX, CXX => shr_kind_CXX + use shr_sys_mod , only : shr_sys_abort + use seq_comm_mct , only : seq_comm_iamroot, seq_comm_setptrs, logunit + use seq_drydep_mod , only : seq_drydep_init, seq_drydep_readnl, lnd_drydep + use shr_megan_mod , only : shr_megan_readnl, shr_megan_mechcomps_n + use shr_fire_emis_mod , only : shr_fire_emis_readnl, shr_fire_emis_mechcomps_n, shr_fire_emis_ztop_token + use shr_carma_mod , only : shr_carma_readnl + use shr_ndep_mod , only : shr_ndep_readnl + + implicit none + public + save + + interface seq_flds_lookup; module procedure & + seq_flds_esmf_metadata_get + end interface + + integer, parameter, private :: CSS = 256 ! use longer short character + integer, parameter, private :: CLL = 1024 + character(len=CXX) :: seq_drydep_fields ! List of dry-deposition fields + character(len=CXX) :: megan_voc_fields ! List of MEGAN VOC emission fields + character(len=CXX) :: fire_emis_fields ! List of fire emission fields + character(len=CX) :: carma_fields ! List of CARMA fields from lnd->atm + character(len=CX) :: ndep_fields ! List of nitrogen deposition fields from atm->lnd/ocn + integer :: ice_ncat ! number of sea ice thickness categories + logical :: seq_flds_i2o_per_cat! .true. if select per ice thickness category fields are passed from ice to ocean + logical :: add_ndep_fields ! .true. => add ndep fields + + !---------------------------------------------------------------------------- + ! metadata + !---------------------------------------------------------------------------- + + character(len=*),parameter :: undef = 'undefined' + integer ,parameter :: nmax = 1000 ! maximum number of entries in lookup_entry + integer :: n_entries = 0 ! actual number of entries in lookup_entry + character(len=CSS), dimension(nmax, 4) :: lookup_entry = undef + + !---------------------------------------------------------------------------- + ! for the domain + !---------------------------------------------------------------------------- + + character(CXX) :: seq_flds_dom_coord + character(CXX) :: seq_flds_dom_other + + !---------------------------------------------------------------------------- + ! state + flux fields + !---------------------------------------------------------------------------- + + character(CXX) :: seq_flds_a2x_states + character(CXX) :: seq_flds_a2x_fluxes + character(CXX) :: seq_flds_x2a_states + character(CXX) :: seq_flds_x2a_fluxes + + character(CXX) :: seq_flds_i2x_states + character(CXX) :: seq_flds_i2x_fluxes + character(CXX) :: seq_flds_x2i_states + character(CXX) :: seq_flds_x2i_fluxes + + character(CXX) :: seq_flds_l2x_states + character(CXX) :: seq_flds_l2x_states_to_glc + character(CXX) :: seq_flds_l2x_fluxes + character(CXX) :: seq_flds_l2x_fluxes_to_glc + character(CXX) :: seq_flds_x2l_states + character(CXX) :: seq_flds_x2l_states_from_glc + character(CXX) :: seq_flds_x2l_fluxes + character(CXX) :: seq_flds_x2l_fluxes_from_glc + + character(CXX) :: seq_flds_o2x_states + character(CXX) :: seq_flds_o2x_fluxes + character(CXX) :: seq_flds_x2o_states + character(CXX) :: seq_flds_x2o_fluxes + + character(CXX) :: seq_flds_g2x_states + character(CXX) :: seq_flds_g2x_states_to_lnd + character(CXX) :: seq_flds_g2x_fluxes + character(CXX) :: seq_flds_g2x_fluxes_to_lnd + character(CXX) :: seq_flds_x2g_states + character(CXX) :: seq_flds_x2g_fluxes + + character(CXX) :: seq_flds_w2x_states + character(CXX) :: seq_flds_w2x_fluxes + character(CXX) :: seq_flds_x2w_states + character(CXX) :: seq_flds_x2w_fluxes + + character(CXX) :: seq_flds_xao_albedo + character(CXX) :: seq_flds_xao_states + character(CXX) :: seq_flds_xao_fluxes + character(CXX) :: seq_flds_xao_diurnl ! for diurnal cycle + + character(CXX) :: seq_flds_r2x_states + character(CXX) :: seq_flds_r2x_fluxes + character(CXX) :: seq_flds_x2r_states + character(CXX) :: seq_flds_x2r_fluxes + character(CXX) :: seq_flds_r2o_liq_fluxes + character(CXX) :: seq_flds_r2o_ice_fluxes + + !---------------------------------------------------------------------------- + ! combined state/flux fields + !---------------------------------------------------------------------------- + + character(CXX) :: seq_flds_dom_fields + character(CXX) :: seq_flds_a2x_fields + character(CXX) :: seq_flds_x2a_fields + character(CXX) :: seq_flds_i2x_fields + character(CXX) :: seq_flds_x2i_fields + character(CXX) :: seq_flds_l2x_fields + character(CXX) :: seq_flds_l2x_fields_to_glc + character(CXX) :: seq_flds_x2l_fields + character(CXX) :: seq_flds_x2l_fields_from_glc + character(CXX) :: seq_flds_o2x_fields + character(CXX) :: seq_flds_x2o_fields + character(CXX) :: seq_flds_xao_fields + character(CXX) :: seq_flds_r2x_fields + character(CXX) :: seq_flds_x2r_fields + character(CXX) :: seq_flds_g2x_fields + character(CXX) :: seq_flds_g2x_fields_to_lnd + character(CXX) :: seq_flds_x2g_fields + character(CXX) :: seq_flds_w2x_fields + character(CXX) :: seq_flds_x2w_fields + + !---------------------------------------------------------------------------- + ! component names + !---------------------------------------------------------------------------- + + character(32) :: atmname='atm' + character(32) :: ocnname='ocn' + character(32) :: icename='ice' + character(32) :: lndname='lnd' + character(32) :: glcname='glc' + character(32) :: wavname='wav' + character(32) :: rofname='rof' + + ! namelist variables + logical :: nan_check_component_fields + +!---------------------------------------------------------------------------- + contains +!---------------------------------------------------------------------------- + + subroutine seq_flds_set(nmlfile, ID, infodata) + +! !USES: + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use shr_string_mod, only : shr_string_listIntersect + use shr_mpi_mod, only : shr_mpi_bcast + use glc_elevclass_mod, only : glc_elevclass_init + use seq_infodata_mod, only : seq_infodata_type, seq_infodata_getdata + +! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: nmlfile ! Name-list filename + integer , intent(in) :: ID ! seq_comm ID + type(seq_infodata_type), intent(in) :: infodata + +! !LOCAL VARIABLES: + integer :: mpicom ! MPI communicator + integer :: ierr ! I/O error code + integer :: unitn ! Namelist unit number to read + + character(len=CSS) :: attname + character(len=CSS) :: units + character(len=CSS) :: longname + character(len=CSS) :: stdname + integer :: num + character(len= 2) :: cnum + character(len=CSS) :: name + character(len=CSS) :: cime_model + + character(CXX) :: dom_coord = '' + character(CXX) :: dom_other = '' + + character(CXX) :: a2x_states = '' + character(CXX) :: a2x_fluxes = '' + character(CXX) :: x2a_states = '' + character(CXX) :: x2a_fluxes = '' + character(CXX) :: i2x_states = '' + character(CXX) :: i2x_fluxes = '' + character(CXX) :: x2i_states = '' + character(CXX) :: x2i_fluxes = '' + character(CXX) :: l2x_states = '' + character(CXX) :: l2x_states_to_glc = '' + character(CXX) :: l2x_fluxes = '' + character(CXX) :: l2x_fluxes_to_glc = '' + character(CXX) :: x2l_states = '' + character(CXX) :: x2l_states_from_glc = '' + character(CXX) :: x2l_fluxes = '' + character(CXX) :: x2l_fluxes_from_glc = '' + character(CXX) :: o2x_states = '' + character(CXX) :: o2x_fluxes = '' + character(CXX) :: x2o_states = '' + character(CXX) :: x2o_fluxes = '' + character(CXX) :: g2x_states = '' + character(CXX) :: g2x_states_to_lnd = '' + character(CXX) :: g2x_fluxes = '' + character(CXX) :: g2x_fluxes_to_lnd = '' + character(CXX) :: x2g_states = '' + character(CXX) :: x2g_fluxes = '' + character(CXX) :: xao_albedo = '' + character(CXX) :: xao_states = '' + character(CXX) :: xao_fluxes = '' + character(CXX) :: xao_diurnl = '' + character(CXX) :: r2x_states = '' + character(CXX) :: r2x_fluxes = '' + character(CXX) :: x2r_states = '' + character(CXX) :: x2r_fluxes = '' + character(CXX) :: w2x_states = '' + character(CXX) :: w2x_fluxes = '' + character(CXX) :: x2w_states = '' + character(CXX) :: x2w_fluxes = '' + character(CXX) :: r2o_liq_fluxes = '' + character(CXX) :: r2o_ice_fluxes = '' + + character(CXX) :: stringtmp = '' + + !------ namelist ----- + character(len=CSS) :: fldname, fldflow + logical :: is_state, is_flux + integer :: i,n + + ! use cases namelists + logical :: flds_co2a + logical :: flds_co2b + logical :: flds_co2c + logical :: flds_co2_dmsa + logical :: flds_bgc_oi + logical :: flds_wiso + integer :: glc_nec + + namelist /seq_cplflds_inparm/ & + flds_co2a, flds_co2b, flds_co2c, flds_co2_dmsa, flds_wiso, glc_nec, & + ice_ncat, seq_flds_i2o_per_cat, flds_bgc_oi, nan_check_component_fields + + ! user specified new fields + integer, parameter :: nfldmax = 200 + character(len=CLL) :: cplflds_custom(nfldmax) = '' + + namelist /seq_cplflds_userspec/ & + cplflds_custom + + character(len=*),parameter :: subname = '(seq_flds_set) ' + +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(ID,mpicom=mpicom) + + call seq_infodata_GetData(infodata, cime_model=cime_model) + + !--------------------------------------------------------------------------- + ! Read in namelist for use cases + !--------------------------------------------------------------------------- + ! TODO: permit duplicates to occur - then check for this in seq_flds_add + ! TODO: add entries for lookup entry table for custom fields + !--------------------------------------------------------------------------- + + if (seq_comm_iamroot(ID)) then + flds_co2a = .false. + flds_co2b = .false. + flds_co2c = .false. + flds_co2_dmsa = .false. + flds_bgc_oi = .false. + flds_wiso = .false. + glc_nec = 0 + ice_ncat = 1 + seq_flds_i2o_per_cat = .false. + nan_check_component_fields = .false. + + unitn = shr_file_getUnit() + write(logunit,"(A)") subname//': read seq_cplflds_inparm namelist from: '& + //trim(nmlfile) + open( unitn, file=trim(nmlfile), status='old' ) + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=seq_cplflds_inparm,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( & + subname//"ERROR: namelist read returns an EOF or EOR condition" ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + end if + call shr_mpi_bcast(flds_co2a , mpicom) + call shr_mpi_bcast(flds_co2b , mpicom) + call shr_mpi_bcast(flds_co2c , mpicom) + call shr_mpi_bcast(flds_co2_dmsa, mpicom) + call shr_mpi_bcast(flds_bgc_oi , mpicom) + call shr_mpi_bcast(flds_wiso , mpicom) + call shr_mpi_bcast(glc_nec , mpicom) + call shr_mpi_bcast(ice_ncat , mpicom) + call shr_mpi_bcast(seq_flds_i2o_per_cat, mpicom) + call shr_mpi_bcast(nan_check_component_fields, mpicom) + + call glc_elevclass_init(glc_nec) + + !--------------------------------------------------------------------------- + ! Read in namelists for user specified new fields + !--------------------------------------------------------------------------- + ! TODO: permit duplicates to occur - then check for this in seq_flds_add + ! TODO: add entries for lookup entry table for custom fields + !--------------------------------------------------------------------------- + + if (seq_comm_iamroot(ID)) then + cplflds_custom(:) = ' ' + + unitn = shr_file_getUnit() + write(logunit,"(A)") subname//': read seq_cplflds_userspec namelist from: '& + //trim(nmlfile) + open( unitn, file=trim(nmlfile), status='old' ) + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=seq_cplflds_userspec,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( & + subname//"ERROR: namelist read returns an EOF or EOR condition" ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + end if + do n = 1, nfldmax + call shr_mpi_bcast(cplflds_custom(n), mpicom) + end do + + ! add customized fields through coupler + + do n = 1,nfldmax + if (cplflds_custom(n) /= ' ') then + i = scan(cplflds_custom(n),'->') + fldname = trim(adjustl(cplflds_custom(n)(:i-1))) + fldflow = trim(adjustl(cplflds_custom(n)(i+2:))) + + if (fldname(1:1) == 'S') then + is_state = .true. + is_flux = .false. + else if (fldname (1:1) == 'F') then + is_state = .false. + is_flux = .true. + else if (fldname (1:2) == 'PF') then + is_state = .false. + is_flux = .true. + else + write(logunit,*) subname//'ERROR: fldname must start with S,F,P, not ',trim(fldname) + call shr_sys_abort(subname//"ERROR: fldname must start with S, F, or P") + end if + + select case (trim(fldflow)) + case('a2x') + if (is_state) call seq_flds_add(a2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(a2x_fluxes,trim(fldname)) + case('x2a') + if (is_state) call seq_flds_add(x2a_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2a_fluxes,trim(fldname)) + case('l2x') + if (is_state) call seq_flds_add(l2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(l2x_fluxes,trim(fldname)) + case('x2l') + if (is_state) call seq_flds_add(x2l_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2l_fluxes,trim(fldname)) + case('r2x') + if (is_state) call seq_flds_add(r2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(r2x_fluxes,trim(fldname)) + case('x2r') + if (is_state) call seq_flds_add(x2r_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2r_fluxes,trim(fldname)) + case('i2x') + if (is_state) call seq_flds_add(i2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(i2x_fluxes,trim(fldname)) + case('x2i') + if (is_state) call seq_flds_add(x2i_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2i_fluxes,trim(fldname)) + case('o2x') + if (is_state) call seq_flds_add(o2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(o2x_fluxes,trim(fldname)) + case('x2o') + if (is_state) call seq_flds_add(x2o_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2o_fluxes,trim(fldname)) + case('g2x') + if (is_state) call seq_flds_add(g2x_states,trim(fldname)) + if (is_flux ) call seq_flds_add(g2x_fluxes,trim(fldname)) + case('x2g') + if (is_state) call seq_flds_add(x2g_states,trim(fldname)) + if (is_flux ) call seq_flds_add(x2g_fluxes,trim(fldname)) + case default + write(logunit,*) subname//'ERROR: ',trim(cplflds_custom(n)),& + ' not a recognized value' + call shr_sys_abort() + end select + else + exit + end if + end do + + !---------------------------------------------------------- + ! domain coordinates + !---------------------------------------------------------- + + call seq_flds_add(dom_coord,'lat') + longname = 'latitude' + stdname = 'latitude' + units = 'degrees north' + attname = 'lat' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_coord,'lon') + longname = 'longitude' + stdname = 'longitude' + units = 'degrees east' + attname = 'lon' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_coord,'hgt') + longname = 'height' + stdname = 'height, depth, or levels' + units = 'unitless' + attname = 'hgt' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_other,'area') + longname = 'cell_area_model' + stdname = 'cell area from model' + units = 'radian^2' + attname = 'area' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_other,'aream') + longname = 'cell_area_mapping' + stdname = 'cell area from mapping file' + units = 'radian^2' + attname = 'aream' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_other,'mask') + longname = 'mask' + stdname = 'mask' + units = '1' + attname = 'mask' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(dom_other,'frac') + longname = 'area_fraction' + stdname = 'area fraction' + units = '1' + attname = 'frac' + call metadata_set(attname, longname, stdname, units) + + !---------------------------------------------------------- + ! states/fluxes from atm + !---------------------------------------------------------- + + ! height at the lowest model level (m) + call seq_flds_add(a2x_states,"Sa_z") + call seq_flds_add(x2l_states,"Sa_z") + call seq_flds_add(x2i_states,"Sa_z") + longname = 'Height at the lowest model level' + stdname = 'height' + units = 'm' + attname = 'Sa_z' + call metadata_set(attname, longname, stdname, units) + + ! topographic height (m) + call seq_flds_add(a2x_states,"Sa_topo") + call seq_flds_add(x2l_states,"Sa_topo") + longname = 'Surface height' + stdname = 'height' + units = 'm' + attname = 'Sa_topo' + call metadata_set(attname, longname, stdname, units) + + ! zonal wind at the lowest model level (m/s) + call seq_flds_add(a2x_states,"Sa_u") + call seq_flds_add(x2l_states,"Sa_u") + call seq_flds_add(x2i_states,"Sa_u") + call seq_flds_add(x2w_states,"Sa_u") + longname = 'Zonal wind at the lowest model level' + stdname = 'eastward_wind' + units = 'm s-1' + attname = 'Sa_u' + call metadata_set(attname, longname, stdname, units) + + ! meridional wind at the lowest model level (m/s) + call seq_flds_add(a2x_states,"Sa_v") + call seq_flds_add(x2l_states,"Sa_v") + call seq_flds_add(x2i_states,"Sa_v") + call seq_flds_add(x2w_states,"Sa_v") + longname = 'Meridional wind at the lowest model level' + stdname = 'northward_wind' + units = 'm s-1' + attname = 'Sa_v' + call metadata_set(attname, longname, stdname, units) + + ! temperature at the lowest model level (K) + call seq_flds_add(a2x_states,"Sa_tbot") + call seq_flds_add(x2l_states,"Sa_tbot") + call seq_flds_add(x2i_states,"Sa_tbot") + call seq_flds_add(x2w_states,"Sa_tbot") + longname = 'Temperature at the lowest model level' + stdname = 'air_temperature' + units = 'K' + attname = 'Sa_tbot' + call metadata_set(attname, longname, stdname, units) + + ! potential temperature at the lowest model level (K) + call seq_flds_add(a2x_states,"Sa_ptem") + call seq_flds_add(x2l_states,"Sa_ptem") + call seq_flds_add(x2i_states,"Sa_ptem") + longname = 'Potential temperature at the lowest model level' + stdname = 'air_potential_temperature' + units = 'K' + attname = 'Sa_ptem' + call metadata_set(attname, longname, stdname, units) + + ! specific humidity at the lowest model level (kg/kg) + call seq_flds_add(a2x_states,"Sa_shum") + call seq_flds_add(x2l_states,"Sa_shum") + call seq_flds_add(x2i_states,"Sa_shum") + longname = 'Specific humidity at the lowest model level' + stdname = 'specific_humidity' + units = 'kg kg-1' + attname = 'Sa_shum' + call metadata_set(attname, longname, stdname, units) + + ! pressure at the lowest model level (Pa) + call seq_flds_add(a2x_states,"Sa_pbot") + call seq_flds_add(x2l_states,"Sa_pbot") + call seq_flds_add(x2i_states,"Sa_pbot") + if (trim(cime_model) == 'acme') then + call seq_flds_add(x2o_states,"Sa_pbot") + end if + longname = 'Pressure at the lowest model level' + stdname = 'air_pressure' + units = 'Pa' + attname = 'Sa_pbot' + call metadata_set(attname, longname, stdname, units) + + ! air density at the lowest model level (kg/m**3) + call seq_flds_add(a2x_states,"Sa_dens") + call seq_flds_add(x2i_states,"Sa_dens") + longname = 'Density at the lowest model level' + stdname = 'air_density' + units = 'kg m-3' + attname = 'Sa_dens' + call metadata_set(attname, longname, stdname, units) + + ! convective precipitation rate + ! large-scale (stable) snow rate (water equivalent) + call seq_flds_add(a2x_fluxes,"Faxa_rainc") + call seq_flds_add(a2x_fluxes,"Faxa_rainl") + call seq_flds_add(x2l_fluxes,"Faxa_rainc") + call seq_flds_add(x2l_fluxes,"Faxa_rainl") + call seq_flds_add(x2i_fluxes,"Faxa_rain" ) + call seq_flds_add(x2o_fluxes,"Faxa_rain" ) + units = 'kg m-2 s-1' + longname = 'Convective precipitation rate' + stdname = 'convective_precipitation_flux' + attname = 'Faxa_rainc' + call metadata_set(attname, longname, stdname, units) + longname = 'Large-scale (stable) precipitation rate' + stdname = 'large_scale_precipitation_flux' + attname = 'Faxa_rainl' + call metadata_set(attname, longname, stdname, units) + longname = 'Water flux due to rain' + stdname = 'rainfall_flux' + attname = 'Faxa_rain' + call metadata_set(attname, longname, stdname, units) + + ! convective snow rate (water equivalent) + ! large-scale (stable) snow rate (water equivalent) + call seq_flds_add(a2x_fluxes,"Faxa_snowc") + call seq_flds_add(a2x_fluxes,"Faxa_snowl") + call seq_flds_add(x2l_fluxes,"Faxa_snowc") + call seq_flds_add(x2l_fluxes,"Faxa_snowl") + call seq_flds_add(x2i_fluxes,"Faxa_snow" ) + call seq_flds_add(x2o_fluxes,"Faxa_snow" ) + units = 'kg m-2 s-1' + longname = 'Convective snow rate (water equivalent)' + stdname = 'convective_snowfall_flux' + attname = 'Faxa_snowc' + call metadata_set(attname, longname, stdname, units) + longname = 'Large-scale (stable) snow rate (water equivalent)' + stdname = 'large_scale_snowfall_flux' + attname = 'Faxa_snowl' + call metadata_set(attname, longname, stdname, units) + longname = 'Water flux due to snow' + stdname = 'surface_snow_melt_flux' + attname = 'Faxa_snow' + call metadata_set(attname, longname, stdname, units) + + ! total precipitation to ocean + call seq_flds_add(x2o_fluxes,"Faxa_prec") ! derived rain+snow + longname = 'Water flux (rain+snow)' + stdname = 'precipitation_flux' + units = 'kg m-2 s-1' + attname = 'Faxa_prec' + call metadata_set(attname, longname, stdname, units) + + ! downward longwave heat flux (W/m**2) + call seq_flds_add(a2x_fluxes,"Faxa_lwdn") + call seq_flds_add(x2l_fluxes,"Faxa_lwdn") + call seq_flds_add(x2i_fluxes,"Faxa_lwdn") + call seq_flds_add(x2o_fluxes,"Faxa_lwdn") + longname = 'Downward longwave heat flux' + stdname = 'downwelling_longwave_flux' + units = 'W m-2' + attname = 'Faxa_lwdn' + call metadata_set(attname, longname, stdname, units) + + ! direct near-infrared incident solar radiation + call seq_flds_add(a2x_fluxes,"Faxa_swndr") + call seq_flds_add(x2i_fluxes,"Faxa_swndr") + call seq_flds_add(x2l_fluxes,"Faxa_swndr") + longname = 'Direct near-infrared incident solar radiation' + stdname = 'surface_downward_direct_shortwave_flux_due_to_near_infrared_radiation' + units = 'W m-2' + attname = 'Faxa_swndr' + call metadata_set(attname, longname, stdname, units) + + ! direct visible incident solar radiation + call seq_flds_add(a2x_fluxes,"Faxa_swvdr") + call seq_flds_add(x2i_fluxes,"Faxa_swvdr") + call seq_flds_add(x2l_fluxes,"Faxa_swvdr") + longname = 'Direct visible incident solar radiation' + stdname = 'surface_downward_direct_shortwave_flux_due_to_visible_radiation' + units = 'W m-2' + attname = 'Faxa_swvdr' + call metadata_set(attname, longname, stdname, units) + + ! diffuse near-infrared incident solar radiation + call seq_flds_add(a2x_fluxes,"Faxa_swndf") + call seq_flds_add(x2i_fluxes,"Faxa_swndf") + call seq_flds_add(x2l_fluxes,"Faxa_swndf") + longname = 'Diffuse near-infrared incident solar radiation' + stdname = 'surface_downward_diffuse_shortwave_flux_due_to_near_infrared_radiation' + units = 'W m-2' + attname = 'Faxa_swndf' + call metadata_set(attname, longname, stdname, units) + + ! diffuse visible incident solar radiation + call seq_flds_add(a2x_fluxes,"Faxa_swvdf") + call seq_flds_add(x2i_fluxes,"Faxa_swvdf") + call seq_flds_add(x2l_fluxes,"Faxa_swvdf") + longname = 'Diffuse visible incident solar radiation' + stdname = 'surface_downward_diffuse_shortwave_flux_due_to_visible_radiation' + units = 'W m-2' + attname = 'Faxa_swvdf' + call metadata_set(attname, longname, stdname, units) + + ! Net shortwave radiation + call seq_flds_add(a2x_fluxes,"Faxa_swnet") ! diagnostic + call seq_flds_add(l2x_fluxes,"Fall_swnet") ! diagnostic + call seq_flds_add(i2x_fluxes,"Faii_swnet") ! diagnostic + + call seq_flds_add(i2x_fluxes,"Fioi_swpen") ! used for Foxx_swnet below + call seq_flds_add(x2o_fluxes,"Foxx_swnet") ! derived using albedos, Faxa_swxxx and swpen + units = 'W m-2' + longname = 'Net shortwave radiation' + stdname = 'surface_net_shortwave_flux' + attname = 'Faxa_swnet' + call metadata_set(attname, longname, stdname, units) + attname = 'Fall_swnet' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_swnet' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_swnet' + call metadata_set(attname, longname, stdname, units) + longname = 'Net shortwave radiation penetrating into ice and ocean' + stdname = 'net_downward_shortwave_flux_in_sea_ice_due_to_penetration' + attname = 'Fioi_swpen' + call metadata_set(attname, longname, stdname, units) + + ! Black Carbon hydrophilic dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_bcphidry" ) + call seq_flds_add(x2i_fluxes,"Faxa_bcphidry" ) + call seq_flds_add(x2l_fluxes,"Faxa_bcphidry" ) + call seq_flds_add(x2o_fluxes,"Faxa_bcphidry" ) + longname = 'Hydrophylic black carbon dry deposition flux' + stdname = 'dry_deposition_flux_of_hydrophylic_black_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_bcphidry' + call metadata_set(attname, longname, stdname, units) + + ! Black Carbon hydrophobic dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_bcphodry" ) + call seq_flds_add(x2i_fluxes,"Faxa_bcphodry" ) + call seq_flds_add(x2l_fluxes,"Faxa_bcphodry" ) + call seq_flds_add(x2o_fluxes,"Faxa_bcphodry") + longname = 'Hydrophobic black carbon dry deposition flux' + stdname = 'dry_deposition_flux_of_hydrophobic_black_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_bcphodry' + call metadata_set(attname, longname, stdname, units) + + ! Black Carbon hydrophilic wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_bcphiwet" ) + call seq_flds_add(x2i_fluxes,"Faxa_bcphiwet" ) + call seq_flds_add(x2l_fluxes,"Faxa_bcphiwet" ) + call seq_flds_add(x2o_fluxes,"Faxa_bcphiwet" ) + longname = 'Hydrophylic black carbon wet deposition flux' + stdname = 'wet_deposition_flux_of_hydrophylic_black_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_bcphiwet' + call metadata_set(attname, longname, stdname, units) + + ! Organic Carbon hydrophilic dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_ocphidry" ) + call seq_flds_add(x2i_fluxes,"Faxa_ocphidry" ) + call seq_flds_add(x2l_fluxes,"Faxa_ocphidry" ) + call seq_flds_add(x2o_fluxes,"Faxa_ocphidry" ) + longname = 'Hydrophylic organic carbon dry deposition flux' + stdname = 'dry_deposition_flux_of_hydrophylic_organic_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_ocphidry' + call metadata_set(attname, longname, stdname, units) + + ! Organic Carbon hydrophobic dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_ocphodry" ) + call seq_flds_add(x2i_fluxes,"Faxa_ocphodry" ) + call seq_flds_add(x2l_fluxes,"Faxa_ocphodry" ) + call seq_flds_add(x2o_fluxes,"Faxa_ocphodry" ) + longname = 'Hydrophobic organic carbon dry deposition flux' + stdname = 'dry_deposition_flux_of_hydrophobic_organic_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_ocphodry' + call metadata_set(attname, longname, stdname, units) + + ! Organic Carbon hydrophilic wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_ocphiwet" ) + call seq_flds_add(x2i_fluxes,"Faxa_ocphiwet" ) + call seq_flds_add(x2l_fluxes,"Faxa_ocphiwet" ) + call seq_flds_add(x2o_fluxes,"Faxa_ocphiwet" ) + longname = 'Hydrophylic organic carbon wet deposition flux' + stdname = 'wet_deposition_flux_of_hydrophylic_organic_carbon' + units = 'kg m-2 s-1' + attname = 'Faxa_ocphiwet' + call metadata_set(attname, longname, stdname, units) + + ! Size 1 dust -- wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstwet1" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstwet1" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstwet1" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstwet1" ) + longname = 'Dust wet deposition flux (size 1)' + stdname = 'wet_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstwet1' + call metadata_set(attname, longname, stdname, units) + + ! Size 2 dust -- wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstwet2" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstwet2" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstwet2" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstwet2" ) + longname = 'Dust wet deposition flux (size 2)' + stdname = 'wet_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstwet2' + call metadata_set(attname, longname, stdname, units) + + ! Size 3 dust -- wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstwet3" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstwet3" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstwet3" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstwet3" ) + longname = 'Dust wet deposition flux (size 3)' + stdname = 'wet_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstwet3' + call metadata_set(attname, longname, stdname, units) + + ! Size 4 dust -- wet deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstwet4" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstwet4" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstwet4" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstwet4" ) + longname = 'Dust wet deposition flux (size 4)' + stdname = 'wet_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstwet4' + call metadata_set(attname, longname, stdname, units) + + ! Size 1 dust -- dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstdry1" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstdry1" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstdry1" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstdry1" ) + longname = 'Dust dry deposition flux (size 1)' + stdname = 'dry_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstdry1' + call metadata_set(attname, longname, stdname, units) + + ! Size 2 dust -- dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstdry2" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstdry2" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstdry2" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstdry2" ) + longname = 'Dust dry deposition flux (size 2)' + stdname = 'dry_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstdry2' + call metadata_set(attname, longname, stdname, units) + + ! Size 3 dust -- dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstdry3" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstdry3" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstdry3" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstdry3" ) + longname = 'Dust dry deposition flux (size 3)' + stdname = 'dry_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstdry3' + call metadata_set(attname, longname, stdname, units) + + ! Size 4 dust -- dry deposition + call seq_flds_add(a2x_fluxes,"Faxa_dstdry4" ) + call seq_flds_add(x2i_fluxes,"Faxa_dstdry4" ) + call seq_flds_add(x2l_fluxes,"Faxa_dstdry4" ) + call seq_flds_add(x2o_fluxes,"Faxa_dstdry4" ) + longname = 'Dust dry deposition flux (size 4)' + stdname = 'dry_deposition_flux_of_dust' + units = 'kg m-2 s-1' + attname = 'Faxa_dstdry4' + call metadata_set(attname, longname, stdname, units) + + !---------------------------------------------------------- + ! states/fluxes to atm (and ocean) + !---------------------------------------------------------- + + ! land/sea-ice/ocean fractions + call seq_flds_add(x2a_states,'Sf_lfrac') + call seq_flds_add(x2a_states,'Sf_ifrac') + call seq_flds_add(x2a_states,'Sf_ofrac') + longname = 'Surface land fraction' + stdname = 'land_area_fraction' + units = '1' + attname = 'Sf_lfrac' + call metadata_set(attname, longname, stdname, units) + longname = 'Surface ice fraction' + stdname = 'sea_ice_area_fraction' + attname = 'Sf_ifrac' + call metadata_set(attname, longname, stdname, units) + longname = 'Surface ocean fraction' + stdname = 'sea_area_fraction' + attname = 'Sf_ofrac' + call metadata_set(attname, longname, stdname, units) + + ! Direct albedo (visible radiation) + call seq_flds_add(i2x_states,"Si_avsdr") + call seq_flds_add(l2x_states,"Sl_avsdr") + call seq_flds_add(xao_albedo,"So_avsdr") + call seq_flds_add(x2a_states,"Sx_avsdr") + longname = 'Direct albedo (visible radiation)' + stdname = 'surface_direct_albedo_due_to_visible_radiation' + units = '1' + attname = 'Si_avsdr' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_avsdr' + call metadata_set(attname, longname, stdname, units) + attname = 'So_avsdr' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_avsdr' + call metadata_set(attname, longname, stdname, units) + + ! Direct albedo (near-infrared radiation) + call seq_flds_add(i2x_states,"Si_anidr") + call seq_flds_add(l2x_states,"Sl_anidr") + call seq_flds_add(xao_albedo,"So_anidr") + call seq_flds_add(x2a_states,"Sx_anidr") + longname = 'Direct albedo (near-infrared radiation)' + stdname = 'surface_direct_albedo_due_to_near_infrared_radiation' + units = '1' + attname = 'Si_anidr' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_anidr' + call metadata_set(attname, longname, stdname, units) + attname = 'So_anidr' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_anidr' + call metadata_set(attname, longname, stdname, units) + + ! Diffuse albedo (visible radiation) + call seq_flds_add(i2x_states,"Si_avsdf") + call seq_flds_add(l2x_states,"Sl_avsdf") + call seq_flds_add(xao_albedo,"So_avsdf") + call seq_flds_add(x2a_states,"Sx_avsdf") + longname = 'Diffuse albedo (visible radiation)' + stdname = 'surface_diffuse_albedo_due_to_visible_radiation' + units = '1' + attname = 'Si_avsdf' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_avsdf' + call metadata_set(attname, longname, stdname, units) + attname = 'So_avsdf' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_avsdf' + call metadata_set(attname, longname, stdname, units) + + ! Diffuse albedo (near-infrared radiation) + call seq_flds_add(i2x_states,"Si_anidf") + call seq_flds_add(l2x_states,"Sl_anidf") + call seq_flds_add(xao_albedo,"So_anidf") + call seq_flds_add(x2a_states,"Sx_anidf") + longname = 'Diffuse albedo (near-infrared radiation)' + stdname = 'surface_diffuse_albedo_due_to_near_infrared_radiation' + units = '1' + attname = 'Si_anidf' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_anidf' + call metadata_set(attname, longname, stdname, units) + attname = 'So_anidf' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_anidf' + call metadata_set(attname, longname, stdname, units) + + ! Reference temperature at 2 meters + call seq_flds_add(l2x_states,"Sl_tref") + call seq_flds_add(i2x_states,"Si_tref") + call seq_flds_add(xao_states,"So_tref") + call seq_flds_add(x2a_states,"Sx_tref") + longname = 'Reference temperature at 2 meters' + stdname = 'air_temperature' + units = 'K' + attname = 'Si_tref' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_tref' + call metadata_set(attname, longname, stdname, units) + attname = 'So_tref' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_tref' + call metadata_set(attname, longname, stdname, units) + + ! Reference specific humidity at 2 meters + call seq_flds_add(l2x_states,"Sl_qref") + call seq_flds_add(i2x_states,"Si_qref") + call seq_flds_add(xao_states,"So_qref") + call seq_flds_add(x2a_states,"Sx_qref") + longname = 'Reference specific humidity at 2 meters' + stdname = 'specific_humidity' + units = 'kg kg-1' + attname = 'Si_qref' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_qref' + call metadata_set(attname, longname, stdname, units) + attname = 'So_qref' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_qref' + call metadata_set(attname, longname, stdname, units) + + ! Surface temperature + call seq_flds_add(l2x_states,"Sl_t") + call seq_flds_add(i2x_states,"Si_t") + call seq_flds_add(x2a_states,"So_t") + call seq_flds_add(x2a_states,"Sx_t") + longname = 'Surface temperature' + stdname = 'surface_temperature' + units = 'K' + attname = 'Si_t' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_t' + call metadata_set(attname, longname, stdname, units) + attname = 'So_t' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_t' + call metadata_set(attname, longname, stdname, units) + + ! Surface friction velocity in land (land/atm only) + call seq_flds_add(l2x_states,"Sl_fv") + call seq_flds_add(x2a_states,"Sl_fv") + longname = 'Surface fraction velocity in land' + stdname = 'fraction_velocity' + units = 'm s-1' + attname = 'Sl_fv' + call metadata_set(attname, longname, stdname, units) + + ! Aerodynamical resistance (land/atm only) + call seq_flds_add(l2x_states,"Sl_ram1") + call seq_flds_add(x2a_states,"Sl_ram1") + longname = 'aerodynamic resistance' + stdname = 'aerodynamic_resistance' + attname = 'SI_ram1' + units = 's/m' + call metadata_set(attname, longname, stdname, units) + + + ! Surface snow water equivalent (land/atm only) + call seq_flds_add(l2x_states,"Sl_snowh") + call seq_flds_add(x2a_states,"Sl_snowh") + longname = 'Surface snow water equivalent' + stdname = 'surface_snow_water_equivalent' + units = 'm' + attname = 'Sl_snowh' + call metadata_set(attname, longname, stdname, units) + + ! Surface snow depth (ice/atm only) + call seq_flds_add(i2x_states,"Si_snowh") + call seq_flds_add(x2a_states,"Si_snowh") + longname = 'Surface snow depth' + stdname = 'surface_snow_thickness' + units = 'm' + attname = 'Si_snowh' + call metadata_set(attname, longname, stdname, units) + + ! Surface saturation specific humidity in ocean (ocn/atm only) + call seq_flds_add(xao_states,"So_ssq") + call seq_flds_add(x2a_states,"So_ssq") + longname = 'Surface saturation specific humidity in ocean' + stdname = 'specific_humidity_at_saturation' + units = 'kg kg-1' + attname = 'So_ssq' + call metadata_set(attname, longname, stdname, units) + + ! Square of exch. coeff (tracers) (ocn/atm only) + call seq_flds_add(xao_states,"So_re") + call seq_flds_add(x2a_states,"So_re") + longname = 'Square of exch. coeff (tracers)' + stdname = '' + units = '' + attname = 'So_re' + call metadata_set(attname, longname, stdname, units) + + ! 10 meter wind + call seq_flds_add(i2x_states,"Si_u10") + call seq_flds_add(xao_states,"So_u10") + call seq_flds_add(l2x_states,"Sl_u10") + call seq_flds_add(x2a_states,"Sx_u10") + longname = '10m wind' + stdname = '10m_wind' + units = 'm' + attname = 'u10' + call metadata_set(attname, longname, stdname, units) + + ! Zonal surface stress" + call seq_flds_add(l2x_fluxes,"Fall_taux") + call seq_flds_add(xao_fluxes,"Faox_taux") + call seq_flds_add(i2x_fluxes,"Faii_taux") + call seq_flds_add(x2a_fluxes,"Faxx_taux") + call seq_flds_add(i2x_fluxes,"Fioi_taux") + call seq_flds_add(x2o_fluxes,"Foxx_taux") + longname = 'Zonal surface stress' + stdname = 'surface_downward_eastward_stress' + units = 'N m-2' + attname = 'Fall_taux' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_taux' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_taux' + call metadata_set(attname, longname, stdname, units) + attname = 'Fioi_taux' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_taux' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_taux' + call metadata_set(attname, longname, stdname, units) + + ! Meridional surface stress + call seq_flds_add(l2x_fluxes,"Fall_tauy") + call seq_flds_add(xao_fluxes,"Faox_tauy") + call seq_flds_add(i2x_fluxes,"Faii_tauy") + call seq_flds_add(x2a_fluxes,"Faxx_tauy") + call seq_flds_add(i2x_fluxes,"Fioi_tauy") + call seq_flds_add(x2o_fluxes,"Foxx_tauy") + longname = 'Meridional surface stress' + stdname = 'surface_downward_northward_stress' + units = 'N m-2' + attname = 'Fall_tauy' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_tauy' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_tauy' + call metadata_set(attname, longname, stdname, units) + attname = 'Fioi_tauy' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_tauy' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_tauy' + call metadata_set(attname, longname, stdname, units) + + ! Surface latent heat flux + call seq_flds_add(l2x_fluxes,"Fall_lat") + call seq_flds_add(xao_fluxes,"Faox_lat") + call seq_flds_add(i2x_fluxes,"Faii_lat") + call seq_flds_add(x2a_fluxes,"Faxx_lat") + call seq_flds_add(x2o_fluxes,"Foxx_lat") + longname = 'Surface latent heat flux' + stdname = 'surface_upward_latent_heat_flux' + units = 'W m-2' + attname = 'Fall_lat' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_lat' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_lat' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_lat' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_lat' + call metadata_set(attname, longname, stdname, units) + + ! Surface sensible heat flux + call seq_flds_add(l2x_fluxes,"Fall_sen") + call seq_flds_add(xao_fluxes,"Faox_sen") + call seq_flds_add(i2x_fluxes,"Faii_sen") + call seq_flds_add(x2a_fluxes,"Faxx_sen") + call seq_flds_add(x2o_fluxes,"Foxx_sen") + longname = 'Sensible heat flux' + stdname = 'surface_upward_sensible_heat_flux' + units = 'W m-2' + attname = 'Fall_sen' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_sen' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_sen' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_sen' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_sen' + call metadata_set(attname, longname, stdname, units) + + ! Surface upward longwave heat flux + call seq_flds_add(l2x_fluxes,"Fall_lwup") + call seq_flds_add(xao_fluxes,"Faox_lwup") + call seq_flds_add(i2x_fluxes,"Faii_lwup") + call seq_flds_add(x2a_fluxes,"Faxx_lwup") + call seq_flds_add(x2o_fluxes,"Foxx_lwup") + longname = 'Surface upward longwave heat flux' + stdname = 'surface_net_upward_longwave_flux' + units = 'W m-2' + attname = 'Fall_lwup' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_lwup' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_lwup' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_lwup' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_lwup' + call metadata_set(attname, longname, stdname, units) + + ! Evaporation water flux + call seq_flds_add(l2x_fluxes,"Fall_evap") + call seq_flds_add(xao_fluxes,"Faox_evap") + call seq_flds_add(i2x_fluxes,"Faii_evap") + call seq_flds_add(x2a_fluxes,"Faxx_evap") + call seq_flds_add(x2o_fluxes,"Foxx_evap") + longname = 'Evaporation water flux' + stdname = 'water_evaporation_flux' + units = 'kg m-2 s-1' + attname = 'Fall_evap' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_evap' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_evap' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_evap' + call metadata_set(attname, longname, stdname, units) + + ! Dust flux (particle bin number 1) + call seq_flds_add(l2x_fluxes,"Fall_flxdst1") + call seq_flds_add(x2a_fluxes,"Fall_flxdst1") + longname = 'Dust flux (particle bin number 1)' + stdname = 'dust_flux' + units = 'kg m-2 s-1' + attname = 'Fall_flxdst1' + call metadata_set(attname, longname, stdname, units) + + ! Dust flux (particle bin number 2) + call seq_flds_add(l2x_fluxes,"Fall_flxdst2") + call seq_flds_add(x2a_fluxes,"Fall_flxdst2") + longname = 'Dust flux (particle bin number 2)' + stdname = 'dust_flux' + units = 'kg m-2 s-1' + attname = 'Fall_flxdst2' + call metadata_set(attname, longname, stdname, units) + + ! Dust flux (particle bin number 3) + call seq_flds_add(l2x_fluxes,"Fall_flxdst3") + call seq_flds_add(x2a_fluxes,"Fall_flxdst3") + longname = 'Dust flux (particle bin number 3)' + stdname = 'dust_flux' + units = 'kg m-2 s-1' + attname = 'Fall_flxdst3' + call metadata_set(attname, longname, stdname, units) + + ! Dust flux (particle bin number 4) + call seq_flds_add(l2x_fluxes,"Fall_flxdst4") + call seq_flds_add(x2a_fluxes,"Fall_flxdst4") + longname = 'Dust flux (particle bin number 4)' + stdname = 'dust_flux' + units = 'kg m-2 s-1' + attname = 'Fall_flxdst4' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + ! atm<->ocn only exchange + !----------------------------- + + ! Sea level pressure (Pa) + call seq_flds_add(a2x_states,"Sa_pslv") + call seq_flds_add(x2o_states,"Sa_pslv") + longname = 'Sea level pressure' + stdname = 'air_pressure_at_sea_level' + units = 'Pa' + attname = 'Sa_pslv' + call metadata_set(attname, longname, stdname, units) + + ! Wind speed squared at 10 meters + call seq_flds_add(xao_states,"So_duu10n") + call seq_flds_add(x2o_states,"So_duu10n") + longname = 'Wind speed squared at 10 meters' + stdname = 'square_of_wind_speed' + units = 'm2 s-2' + attname = 'So_duu10n' + call metadata_set(attname, longname, stdname, units) + + ! Surface friction velocity in ocean + call seq_flds_add(xao_states,"So_ustar") + call seq_flds_add(x2a_states,"So_ustar") + longname = 'Surface fraction velocity in ocean' + stdname = 'fraction_velocity' + units = 'm s-1' + attname = 'So_ustar' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + ! ice<->ocn only exchange + !----------------------------- + + ! Fractional ice coverage wrt ocean + call seq_flds_add(i2x_states,"Si_ifrac") + call seq_flds_add(x2o_states,"Si_ifrac") + call seq_flds_add(x2w_states,"Si_ifrac") + longname = 'Fractional ice coverage wrt ocean' + stdname = 'sea_ice_area_fraction' + units = '1' + attname = 'Si_ifrac' + call metadata_set(attname, longname, stdname, units) + + if (trim(cime_model) == 'acme') then + ! Sea ice basal pressure + call seq_flds_add(i2x_states,"Si_bpress") + call seq_flds_add(x2o_states,"Si_bpress") + longname = 'Sea ice basal pressure' + stdname = 'cice_basal_pressure' + units = 'Pa' + attname = 'Si_bpress' + call metadata_set(attname, longname, stdname, units) + end if + + ! Ocean melt and freeze potential + call seq_flds_add(o2x_fluxes,"Fioo_q") + call seq_flds_add(x2i_fluxes,"Fioo_q") + longname = 'Ocean melt and freeze potential' + stdname = 'surface_snow_and_ice_melt_heat_flux' + units = 'W m-2' + attname = 'Fioo_q' + call metadata_set(attname, longname, stdname, units) + + if (trim(cime_model) == 'acme') then + ! Ocean melt (q<0) potential + call seq_flds_add(o2x_fluxes,"Fioo_meltp") + call seq_flds_add(x2i_fluxes,"Fioo_meltp") + longname = 'Ocean melt (q<0) potential' + stdname = 'surface_snow_and_ice_melt_heat_flux' + units = 'W m-2' + attname = 'Fioo_meltp' + call metadata_set(attname, longname, stdname, units) + end if + + if (trim(cime_model) == 'acme') then + ! Ocean frazil production + call seq_flds_add(o2x_fluxes,"Fioo_frazil") + call seq_flds_add(x2i_fluxes,"Fioo_frazil") + longname = 'Ocean frazil production' + stdname = 'ocean_frazil_ice_production' + units = 'kg m-2 s-1' + attname = 'Fioo_frazil' + call metadata_set(attname, longname, stdname, units) + end if + + ! Heat flux from melting + call seq_flds_add(i2x_fluxes,"Fioi_melth") + call seq_flds_add(x2o_fluxes,"Fioi_melth") + longname = 'Heat flux from melting' + stdname = 'surface_snow_melt_heat_flux' + units = 'W m-2' + attname = 'Fioi_melth' + call metadata_set(attname, longname, stdname, units) + + ! Water flux from melting + call seq_flds_add(i2x_fluxes,"Fioi_meltw") + call seq_flds_add(x2o_fluxes,"Fioi_meltw") + longname = 'Water flux due to melting' + stdname = 'surface_snow_melt_flux' + units = 'kg m-2 s-1' + attname = 'Fioi_meltw' + call metadata_set(attname, longname, stdname, units) + + ! Salt flux + call seq_flds_add(i2x_fluxes,"Fioi_salt") + call seq_flds_add(x2o_fluxes,"Fioi_salt") + longname = 'Salt flux' + stdname = 'virtual_salt_flux_into_sea_water' + units = 'kg m-2 s-1' + attname = 'Fioi_salt' + call metadata_set(attname, longname, stdname, units) + + ! Black Carbon hydrophilic deposition + call seq_flds_add(i2x_fluxes,"Fioi_bcphi" ) + call seq_flds_add(x2o_fluxes,"Fioi_bcphi" ) + longname = 'Hydrophylic black carbon deposition flux' + stdname = 'deposition_flux_of_hydrophylic_black_carbon' + units = 'kg m-2 s-1' + attname = 'Fioi_bcphi' + call metadata_set(attname, longname, stdname, units) + + ! Black Carbon hydrophobic deposition + call seq_flds_add(i2x_fluxes,"Fioi_bcpho" ) + call seq_flds_add(x2o_fluxes,"Fioi_bcpho" ) + longname = 'Hydrophobic black carbon deposition flux' + stdname = 'deposition_flux_of_hydrophobic_black_carbon' + units = 'kg m-2 s-1' + attname = 'Fioi_bcpho' + call metadata_set(attname, longname, stdname, units) + + ! Dust flux + call seq_flds_add(i2x_fluxes,"Fioi_flxdst") + call seq_flds_add(x2o_fluxes,"Fioi_flxdst") + longname = 'Dust flux' + stdname = 'dust_flux' + units = 'kg m-2 s-1' + attname = 'Fioi_flxdst' + call metadata_set(attname, longname, stdname, units) + + ! Sea surface temperature + call seq_flds_add(o2x_states,"So_t") + call seq_flds_add(x2i_states,"So_t") + call seq_flds_add(x2w_states,"So_t") + + ! Sea surface salinity + call seq_flds_add(o2x_states,"So_s") + call seq_flds_add(x2i_states,"So_s") + longname = 'Sea surface salinity' + stdname = 'sea_surface_salinity' + units = 'g kg-1' + attname = 'So_s' + call metadata_set(attname, longname, stdname, units) + + ! Zonal sea water velocity + call seq_flds_add(o2x_states,"So_u") + call seq_flds_add(x2i_states,"So_u") + call seq_flds_add(x2w_states,"So_u") + longname = 'Zonal sea water velocity' + stdname = 'eastward_sea_water_velocity' + units = 'm s-1' + attname = 'So_u' + call metadata_set(attname, longname, stdname, units) + + ! Meridional sea water velocity + call seq_flds_add(o2x_states,"So_v") + call seq_flds_add(x2i_states,"So_v") + call seq_flds_add(x2w_states,"So_v") + longname = 'Meridional sea water velocity' + stdname = 'northward_sea_water_velocity' + units = 'm s-1' + attname = 'So_v' + + ! Zonal sea surface slope + call seq_flds_add(o2x_states,"So_dhdx") + call seq_flds_add(x2i_states,"So_dhdx") + longname = 'Zonal sea surface slope' + stdname = 'sea_surface_eastward_slope' + units = 'm m-1' + attname = 'So_dhdx' + call metadata_set(attname, longname, stdname, units) + + ! Meridional sea surface slope + call seq_flds_add(o2x_states,"So_dhdy") + call seq_flds_add(x2i_states,"So_dhdy") + longname = 'Meridional sea surface slope' + stdname = 'sea_surface_northward_slope' + units = 'm m-1' + attname = 'So_dhdy' + call metadata_set(attname, longname, stdname, units) + + ! Boundary Layer Depth + call seq_flds_add(o2x_states,"So_bldepth") + call seq_flds_add(x2w_states,"So_bldepth") + longname = 'Ocean Boundary Layer Depth' + stdname = 'ocean_boundary_layer_depth' + units = 'm' + attname = 'So_bldepth' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_states,"So_fswpen") + call seq_flds_add(o2x_states,"So_fswpen") + longname = 'Fraction of sw penetrating surface layer for diurnal cycle' + stdname = 'Fraction of sw penetrating surface layer for diurnal cycle' + units = '1' + attname = 'So_fswpen' + call metadata_set(attname, longname, stdname, units) + + !------------------------------ + ! ice<->ocn only exchange - BGC + !------------------------------ + if (trim(cime_model) == 'acme' .and. flds_bgc_oi) then + + ! Ocean algae concentration 1 - diatoms? + call seq_flds_add(o2x_states,"So_algae1") + call seq_flds_add(x2i_states,"So_algae1") + longname = 'Ocean algae concentration 1 - diatoms' + stdname = 'ocean_algae_conc_1' + units = 'mmol C m-3' + attname = 'So_algae1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean algae concentration 2 - flagellates? + call seq_flds_add(o2x_states,"So_algae2") + call seq_flds_add(x2i_states,"So_algae2") + longname = 'Ocean algae concentration 2 - flagellates' + stdname = 'ocean_algae_conc_2' + units = 'mmol C m-3' + attname = 'So_algae2' + call metadata_set(attname, longname, stdname, units) + + ! Ocean algae concentration 3 - phaeocyctis? + call seq_flds_add(o2x_states,"So_algae3") + call seq_flds_add(x2i_states,"So_algae3") + longname = 'Ocean algae concentration 3 - phaeocyctis' + stdname = 'ocean_algae_conc_3' + units = 'mmol C m-3' + attname = 'So_algae3' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved organic carbon concentration 1 - saccharides? + call seq_flds_add(o2x_states,"So_doc1") + call seq_flds_add(x2i_states,"So_doc1") + longname = 'Ocean dissolved organic carbon concentration 1 - saccharides' + stdname = 'ocean_dissolved_organic_carbon_conc_1' + units = 'mmol C m-3' + attname = 'So_doc1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved organic carbon concentration 2 - lipids? + call seq_flds_add(o2x_states,"So_doc2") + call seq_flds_add(x2i_states,"So_doc2") + longname = 'Ocean dissolved organic carbon concentration 2 - lipids' + stdname = 'ocean_dissolved_organic_carbon_conc_2' + units = 'mmol C m-3' + attname = 'So_doc2' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved organic carbon concentration 3 - tbd? + call seq_flds_add(o2x_states,"So_doc3") + call seq_flds_add(x2i_states,"So_doc3") + longname = 'Ocean dissolved organic carbon concentration 3 - tbd' + stdname = 'ocean_dissolved_organic_carbon_conc_3' + units = 'mmol C m-3' + attname = 'So_doc3' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved inorganic carbon concentration 1 + call seq_flds_add(o2x_states,"So_dic1") + call seq_flds_add(x2i_states,"So_dic1") + longname = 'Ocean dissolved inorganic carbon concentration 1' + stdname = 'ocean_dissolved_inorganic_carbon_conc_1' + units = 'mmol C m-3' + attname = 'So_dic1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved organic nitrogen concentration 1 + call seq_flds_add(o2x_states,"So_don1") + call seq_flds_add(x2i_states,"So_don1") + longname = 'Ocean dissolved organic nitrogen concentration 1' + stdname = 'ocean_dissolved_organic_nitrogen_conc_1' + units = 'mmol N m-3' + attname = 'So_don1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean nitrate concentration + call seq_flds_add(o2x_states,"So_no3") + call seq_flds_add(x2i_states,"So_no3") + longname = 'Ocean nitrate concentration' + stdname = 'ocean_nitrate_conc' + units = 'mmol N m-3' + attname = 'So_no3' + call metadata_set(attname, longname, stdname, units) + + ! Ocean silicate concentration + call seq_flds_add(o2x_states,"So_sio3") + call seq_flds_add(x2i_states,"So_sio3") + longname = 'Ocean silicate concentration' + stdname = 'ocean_silicate_conc' + units = 'mmol Si m-3' + attname = 'So_sio3' + call metadata_set(attname, longname, stdname, units) + + ! Ocean ammonium concentration + call seq_flds_add(o2x_states,"So_nh4") + call seq_flds_add(x2i_states,"So_nh4") + longname = 'Ocean ammonium concentration' + stdname = 'ocean_ammonium_conc' + units = 'mmol N m-3' + attname = 'So_nh4' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dimethyl sulfide (DMS) concentration + call seq_flds_add(o2x_states,"So_dms") + call seq_flds_add(x2i_states,"So_dms") + longname = 'Ocean dimethyl sulfide concentration' + stdname = 'ocean_dimethyl_sulfide_conc' + units = 'mmol S m-3' + attname = 'So_dms' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dimethylsulphonio-propionate (DMSP) concentration + call seq_flds_add(o2x_states,"So_dmsp") + call seq_flds_add(x2i_states,"So_dmsp") + longname = 'Ocean dimethylsulphonio-propionate concentration' + stdname = 'ocean_dimethylsulphoniopropionate_conc' + units = 'mmol S m-3' + attname = 'So_dmsp' + call metadata_set(attname, longname, stdname, units) + + ! Ocean DOCr concentration + call seq_flds_add(o2x_states,"So_docr") + call seq_flds_add(x2i_states,"So_docr") + longname = 'Ocean DOCr concentration' + stdname = 'ocean_DOCr_conc' + units = 'mmol C m-3' + attname = 'So_docr' + call metadata_set(attname, longname, stdname, units) + + ! Ocean particulate iron concentration 1 + call seq_flds_add(o2x_states,"So_fep1") + call seq_flds_add(x2i_states,"So_fep1") + longname = 'Ocean particulate iron concentration 1' + stdname = 'ocean_particulate_iron_conc_1' + units = 'umol Fe m-3' + attname = 'So_fep1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean particulate iron concentration 2 + call seq_flds_add(o2x_states,"So_fep2") + call seq_flds_add(x2i_states,"So_fep2") + longname = 'Ocean particulate iron concentration 2' + stdname = 'ocean_particulate_iron_conc_2' + units = 'umol Fe m-3' + attname = 'So_fep2' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved iron concentration 1 + call seq_flds_add(o2x_states,"So_fed1") + call seq_flds_add(x2i_states,"So_fed1") + longname = 'Ocean dissolved iron concentration 1' + stdname = 'ocean_dissolved_iron_conc_1' + units = 'umol Fe m-3' + attname = 'So_fed1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean dissolved iron concentration 2 + call seq_flds_add(o2x_states,"So_fed2") + call seq_flds_add(x2i_states,"So_fed2") + longname = 'Ocean dissolved iron concentration 2' + stdname = 'ocean_dissolved_iron_conc_2' + units = 'umol Fe m-3' + attname = 'So_fed2' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 1 + call seq_flds_add(o2x_states,"So_zaer1") + call seq_flds_add(x2i_states,"So_zaer1") + longname = 'Ocean z-aerosol concentration 1' + stdname = 'ocean_z_aerosol_conc_1' + units = 'kg m-3' + attname = 'So_zaer1' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 2 + call seq_flds_add(o2x_states,"So_zaer2") + call seq_flds_add(x2i_states,"So_zaer2") + longname = 'Ocean z-aerosol concentration 2' + stdname = 'ocean_z_aerosol_conc_2' + units = 'kg m-3' + attname = 'So_zaer2' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 3 + call seq_flds_add(o2x_states,"So_zaer3") + call seq_flds_add(x2i_states,"So_zaer3") + longname = 'Ocean z-aerosol concentration 3' + stdname = 'ocean_z_aerosol_conc_3' + units = 'kg m-3' + attname = 'So_zaer3' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 4 + call seq_flds_add(o2x_states,"So_zaer4") + call seq_flds_add(x2i_states,"So_zaer4") + longname = 'Ocean z-aerosol concentration 4' + stdname = 'ocean_z_aerosol_conc_4' + units = 'kg m-3' + attname = 'So_zaer4' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 5 + call seq_flds_add(o2x_states,"So_zaer5") + call seq_flds_add(x2i_states,"So_zaer5") + longname = 'Ocean z-aerosol concentration 5' + stdname = 'ocean_z_aerosol_conc_5' + units = 'kg m-3' + attname = 'So_zaer5' + call metadata_set(attname, longname, stdname, units) + + ! Ocean z-aerosol concentration 6 + call seq_flds_add(o2x_states,"So_zaer6") + call seq_flds_add(x2i_states,"So_zaer6") + longname = 'Ocean z-aerosol concentration 6' + stdname = 'ocean_z_aerosol_conc_6' + units = 'kg m-3' + attname = 'So_zaer6' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice algae flux 1 - diatoms? + call seq_flds_add(i2x_fluxes,"Fioi_algae1") + call seq_flds_add(x2o_fluxes,"Fioi_algae1") + longname = 'Sea ice algae flux 1 - diatoms' + stdname = 'seaice_algae_flux_1' + units = 'mmol C m-2 s-1' + attname = 'Fioi_algae1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice algae flux 2 - flagellates? + call seq_flds_add(i2x_fluxes,"Fioi_algae2") + call seq_flds_add(x2o_fluxes,"Fioi_algae2") + longname = 'Sea ice algae flux 2 - flagellates' + stdname = 'seaice_algae_flux_2' + units = 'mmol C m-2 s-1' + attname = 'Fioi_algae2' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice algae flux 3 - phaeocyctis? + call seq_flds_add(i2x_fluxes,"Fioi_algae3") + call seq_flds_add(x2o_fluxes,"Fioi_algae3") + longname = 'Sea ice algae flux 3 - phaeocyctis' + stdname = '_algae_flux_3' + units = 'mmol C m-2 s-1' + attname = 'Fioi_algae3' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved organic carbon flux 1 - saccharides? + call seq_flds_add(i2x_fluxes,"Fioi_doc1") + call seq_flds_add(x2o_fluxes,"Fioi_doc1") + longname = 'Sea ice dissolved organic carbon flux 1 - saccharides' + stdname = 'seaice_dissolved_organic_carbon_flux_1' + units = 'mmol C m-2 s-1' + attname = 'Fioi_doc1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved organic carbon flux 2 - lipids? + call seq_flds_add(i2x_fluxes,"Fioi_doc2") + call seq_flds_add(x2o_fluxes,"Fioi_doc2") + longname = 'Sea ice dissolved organic carbon flux 2 - lipids' + stdname = 'seaice_dissolved_organic_carbon_flux_2' + units = 'mmol C m-2 s-1' + attname = 'Fioi_doc2' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved organic carbon flux 3 - tbd? + call seq_flds_add(i2x_fluxes,"Fioi_doc3") + call seq_flds_add(x2o_fluxes,"Fioi_doc3") + longname = 'Sea ice dissolved organic carbon flux 3 - tbd' + stdname = 'seaice_dissolved_organic_carbon_flux_3' + units = 'mmol C m-2 s-1' + attname = 'Fioi_doc3' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved inorganic carbon flux 1 + call seq_flds_add(i2x_fluxes,"Fioi_dic1") + call seq_flds_add(x2o_fluxes,"Fioi_dic1") + longname = 'Sea ice dissolved inorganic carbon flux 1' + stdname = 'seaice_dissolved_inorganic_carbon_flux_1' + units = 'mmol C m-2 s-1' + attname = 'Fioi_dic1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved organic nitrogen flux 1 + call seq_flds_add(i2x_fluxes,"Fioi_don1") + call seq_flds_add(x2o_fluxes,"Fioi_don1") + longname = 'Sea ice dissolved organic nitrogen flux 1' + stdname = 'seaice_dissolved_organic_nitrogen_flux_1' + units = 'mmol N m-2 s-1' + attname = 'Fioi_don1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice nitrate flux + call seq_flds_add(i2x_fluxes,"Fioi_no3") + call seq_flds_add(x2o_fluxes,"Fioi_no3") + longname = 'Sea ice nitrate flux' + stdname = 'seaice_nitrate_flux' + units = 'mmol N m-2 s-1' + attname = 'Fioi_no3' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice silicate flux + call seq_flds_add(i2x_fluxes,"Fioi_sio3") + call seq_flds_add(x2o_fluxes,"Fioi_sio3") + longname = 'Sea ice silicate flux' + stdname = 'seaice_silicate_flux' + units = 'mmol Si m-2 s-1' + attname = 'Fioi_sio3' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice ammonium flux + call seq_flds_add(i2x_fluxes,"Fioi_nh4") + call seq_flds_add(x2o_fluxes,"Fioi_nh4") + longname = 'Sea ice ammonium flux' + stdname = 'seaice_ammonium_flux' + units = 'mmol N m-2 s-1' + attname = 'Fioi_nh4' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dimethyl sulfide (DMS) flux + call seq_flds_add(i2x_fluxes,"Fioi_dms") + call seq_flds_add(x2o_fluxes,"Fioi_dms") + longname = 'Sea ice dimethyl sulfide flux' + stdname = 'seaice_dimethyl_sulfide_flux' + units = 'mmol S m-2 s-1' + attname = 'Fioi_dms' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice DMSPp flux + call seq_flds_add(i2x_fluxes,"Fioi_dmspp") + call seq_flds_add(x2o_fluxes,"Fioi_dmspp") + longname = 'Sea ice DSMPp flux' + stdname = 'seaice_DSMPp_flux' + units = 'mmol S m-2 s-1' + attname = 'Fioi_dmspp' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice DMSPd flux + call seq_flds_add(i2x_fluxes,"Fioi_dmspd") + call seq_flds_add(x2o_fluxes,"Fioi_dmspd") + longname = 'Sea ice DSMPd flux' + stdname = 'seaice_DSMPd_flux' + units = 'mmol S m-2 s-1' + attname = 'Fioi_dmspd' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice DOCr flux + call seq_flds_add(i2x_fluxes,"Fioi_docr") + call seq_flds_add(x2o_fluxes,"Fioi_docr") + longname = 'Sea ice DOCr flux' + stdname = 'seaice_DOCr_flux' + units = 'mmol C m-2 s-1' + attname = 'Fioi_docr' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice particulate iron flux 1 + call seq_flds_add(i2x_fluxes,"Fioi_fep1") + call seq_flds_add(x2o_fluxes,"Fioi_fep1") + longname = 'Sea ice particulate iron flux 1' + stdname = 'seaice_particulate_iron_flux_1' + units = 'umol Fe m-2 s-1' + attname = 'Fioi_fep1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice particulate iron flux 2 + call seq_flds_add(i2x_fluxes,"Fioi_fep2") + call seq_flds_add(x2o_fluxes,"Fioi_fep2") + longname = 'Sea ice particulate iron flux 2' + stdname = 'seaice_particulate_iron_flux_2' + units = 'umol Fe m-2 s-1' + attname = 'Fioi_fep2' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved iron flux 1 + call seq_flds_add(i2x_fluxes,"Fioi_fed1") + call seq_flds_add(x2o_fluxes,"Fioi_fed1") + longname = 'Sea ice dissolved iron flux 1' + stdname = 'seaice_dissolved_iron_flux_1' + units = 'umol Fe m-2 s-1' + attname = 'Fioi_fed1' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice dissolved iron flux 2 + call seq_flds_add(i2x_fluxes,"Fioi_fed2") + call seq_flds_add(x2o_fluxes,"Fioi_fed2") + longname = 'Sea ice dissolved iron flux 2' + stdname = 'seaice_dissolved_iron_flux_2' + units = 'umol Fe m-2 s-1' + attname = 'Fioi_fed2' + call metadata_set(attname, longname, stdname, units) + + ! Sea ice iron dust + call seq_flds_add(i2x_fluxes,"Fioi_dust1") + call seq_flds_add(x2o_fluxes,"Fioi_dust1") + longname = 'Sea ice iron dust 1' + stdname = 'seaice_iron_dust_1' + units = 'kg m-2 s-1' + attname = 'Fioi_dust1' + call metadata_set(attname, longname, stdname, units) + + endif + + + !----------------------------- + ! lnd->rof exchange + ! TODO: put in attributes below + !----------------------------- + + call seq_flds_add(l2x_fluxes,'Flrl_rofsur') + call seq_flds_add(x2r_fluxes,'Flrl_rofsur') + longname = 'Water flux from land (liquid surface)' + stdname = 'water_flux_into_runoff_surface' + units = 'kg m-2 s-1' + attname = 'Flrl_rofsur' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes,'Flrl_rofgwl') + call seq_flds_add(x2r_fluxes,'Flrl_rofgwl') + longname = 'Water flux from land (liquid glacier, wetland, and lake)' + stdname = 'water_flux_into_runoff_from_gwl' + units = 'kg m-2 s-1' + attname = 'Flrl_rofgwl' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes,'Flrl_rofsub') + call seq_flds_add(x2r_fluxes,'Flrl_rofsub') + longname = 'Water flux from land (liquid subsurface)' + stdname = 'water_flux_into_runoff_subsurface' + units = 'kg m-2 s-1' + attname = 'Flrl_rofsub' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes,'Flrl_rofdto') + call seq_flds_add(x2r_fluxes,'Flrl_rofdto') + longname = 'Water flux from land direct to ocean' + stdname = 'water_flux_direct_to_ocean' + units = 'kg m-2 s-1' + attname = 'Flrl_rofdto' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes,'Flrl_rofi') + call seq_flds_add(x2r_fluxes,'Flrl_rofi') + longname = 'Water flux from land (frozen)' + stdname = 'frozen_water_flux_into_runoff' + units = 'kg m-2 s-1' + attname = 'Flrl_rofi' + call metadata_set(attname, longname, stdname, units) + + ! Currently only the CESM land and runoff models treat irrigation as a separate + ! field: in ACME, this field is folded in to the other runoff fields. Eventually, + ! ACME may want to update its land and runoff models to map irrigation specially, as + ! CESM does. + ! + ! (Once ACME is using this irrigation field, all that needs to be done is to remove + ! this conditional: Code in other places in the coupler is written to trigger off of + ! whether Flrl_irrig has been added to the field list, so it should Just Work if this + ! conditional is removed.) + if (trim(cime_model) == 'cesm') then + ! Irrigation flux (land/rof only) + call seq_flds_add(l2x_fluxes,"Flrl_irrig") + call seq_flds_add(x2r_fluxes,"Flrl_irrig") + longname = 'Irrigation flux (withdrawal from rivers)' + stdname = 'irrigation' + units = 'kg m-2 s-1' + attname = 'Flrl_irrig' + call metadata_set(attname, longname, stdname, units) + end if + + !----------------------------- + ! rof->ocn (runoff) and rof->lnd (flooding) + !----------------------------- + + call seq_flds_add(r2x_fluxes,'Forr_rofl') + call seq_flds_add(x2o_fluxes,'Foxx_rofl') + call seq_flds_add(r2o_liq_fluxes,'Forr_rofl') + longname = 'Water flux due to runoff (liquid)' + stdname = 'water_flux_into_sea_water' + units = 'kg m-2 s-1' + attname = 'Forr_rofl' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofl' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Forr_rofi') + call seq_flds_add(x2o_fluxes,'Foxx_rofi') + call seq_flds_add(r2o_ice_fluxes,'Forr_rofi') + longname = 'Water flux due to runoff (frozen)' + stdname = 'frozen_water_flux_into_sea_water' + units = 'kg m-2 s-1' + attname = 'Forr_rofi' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofi' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Firr_rofi') + call seq_flds_add(x2i_fluxes,'Fixx_rofi') + longname = 'Water flux due to runoff (frozen)' + stdname = 'frozen_water_flux_into_sea_ice' + units = 'kg m-2 s-1' + attname = 'Firr_rofi' + call metadata_set(attname, longname, stdname, units) + attname = 'Fixx_rofi' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Flrr_flood') + call seq_flds_add(x2l_fluxes,'Flrr_flood') + longname = 'Waterrflux due to flooding' + stdname = 'flooding_water_flux' + units = 'kg m-2 s-1' + attname = 'Flrr_flood' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Flrr_volr') + call seq_flds_add(x2l_fluxes,'Flrr_volr') + longname = 'River channel total water volume' + stdname = 'rtm_volr' + units = 'm' + attname = 'Flrr_volr' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Flrr_volrmch') + call seq_flds_add(x2l_fluxes,'Flrr_volrmch') + longname = 'River channel main channel water volume' + stdname = 'rtm_volrmch' + units = 'm' + attname = 'Flrr_volrmch' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + ! wav->ocn and ocn->wav + !----------------------------- + + call seq_flds_add(w2x_states,'Sw_lamult') + call seq_flds_add(x2o_states,'Sw_lamult') + longname = 'Langmuir multiplier' + stdname = 'wave_model_langmuir_multiplier' + units = '' + attname = 'Sw_lamult' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(w2x_states,'Sw_ustokes') + call seq_flds_add(x2o_states,'Sw_ustokes') + longname = 'Stokes drift u component' + stdname = 'wave_model_stokes_drift_eastward_velocity' + units = 'm/s' + attname = 'Sw_ustokes' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(w2x_states,'Sw_vstokes') + call seq_flds_add(x2o_states,'Sw_vstokes') + longname = 'Stokes drift v component' + stdname = 'wave_model_stokes_drift_northward_velocity' + units = 'm/s' + attname = 'Sw_vstokes' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(w2x_states,'Sw_hstokes') + call seq_flds_add(x2o_states,'Sw_hstokes') + longname = 'Stokes drift depth' + stdname = 'wave_model_stokes_drift_depth' + units = 'm' + attname = 'Sw_hstokes' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + ! New xao_states diagnostic + ! fields for history output only + !----------------------------- + + call seq_flds_add(xao_fluxes,"Faox_swdn") + longname = 'Downward solar radiation' + stdname = 'surface_downward_shortwave_flux' + units = 'W m-2' + attname = 'Faox_swdn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_fluxes,"Faox_swup") + longname = 'Upward solar radiation' + stdname = 'surface_upward_shortwave_flux' + units = 'W m-2' + attname = 'Faox_swup' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_tbulk_diurn") + longname = 'atm/ocn flux temperature bulk' + stdname = 'aoflux_tbulk' + units = 'K' + attname = 'So_tbulk_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_tskin_diurn") + longname = 'atm/ocn flux temperature skin' + stdname = 'aoflux_tskin' + units = 'K' + attname = 'So_tskin_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_tskin_night_diurn") + longname = 'atm/ocn flux temperature skin at night' + stdname = 'aoflux_tskin_night' + units = 'K' + attname = 'So_tskin_night_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_tskin_day_diurn") + longname = 'atm/ocn flux temperature skin at day' + stdname = 'aoflux_tskin_day' + units = 'K' + attname = 'So_tskin_day_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_cskin_diurn") + longname = 'atm/ocn flux cool skin' + stdname = 'aoflux_cskin' + units = 'K' + attname = 'So_cskin_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_cskin_night_diurn") + longname = 'atm/ocn flux cool skin at night' + stdname = 'aoflux_cskin_night' + units = 'K' + attname = 'So_cskin_night_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_warm_diurn") + longname = 'atm/ocn flux warming' + stdname = 'aoflux_warm' + units = 'unitless' + attname = 'So_warm_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_salt_diurn") + longname = 'atm/ocn flux salting' + stdname = 'aoflux_salt' + units = 'unitless' + attname = 'So_salt_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_speed_diurn") + longname = 'atm/ocn flux speed' + stdname = 'aoflux_speed' + units = 'unitless' + attname = 'So_speed_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_regime_diurn") + longname = 'atm/ocn flux regime' + stdname = 'aoflux_regime' + units = 'unitless' + attname = 'So_regime_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_warmmax_diurn") + longname = 'atm/ocn flux warming dialy max' + stdname = 'aoflux_warmmax' + units = 'unitless' + attname = 'So_warmmax_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_windmax_diurn") + longname = 'atm/ocn flux wind daily max' + stdname = 'aoflux_windmax' + units = 'unitless' + attname = 'So_windmax_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_qsolavg_diurn") + longname = 'atm/ocn flux q-solar daily avg' + stdname = 'aoflux_qsolavg' + units = 'unitless' + attname = 'So_qsolavg_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_windavg_diurn") + longname = 'atm/ocn flux wind daily avg' + stdname = 'aoflux_windavg' + units = 'unitless' + attname = 'So_windavg_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_warmmaxinc_diurn") + longname = 'atm/ocn flux daily max increment' + stdname = 'aoflux_warmmaxinc' + units = 'unitless' + attname = 'So_warmmaxinc_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_windmaxinc_diurn") + longname = 'atm/ocn flux wind daily max increment' + stdname = 'aoflux_windmaxinc' + units = 'unitless' + attname = 'So_windmaxinc_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_qsolinc_diurn") + longname = 'atm/ocn flux q-solar increment' + stdname = 'aoflux_qsolinc' + units = 'unitless' + attname = 'So_qsolinc_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_windinc_diurn") + longname = 'atm/ocn flux wind increment' + stdname = 'aoflux_windinc' + units = 'unitless' + attname = 'So_windinc_diurn' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(xao_diurnl,"So_ninc_diurn") + longname = 'atm/ocn flux increment counter' + stdname = 'aoflux_ninc' + units = 'unitless' + attname = 'So_ninc_diurn' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + ! glc fields + !----------------------------- + + name = 'Fogg_rofl' + call seq_flds_add(g2x_fluxes,trim(name)) + longname = 'glc liquid runoff flux to ocean' + stdname = 'glacier_liquid_runoff_flux_to_ocean' + units = 'kg m-2 s-1' + attname = 'Fogg_rofl' + call metadata_set(attname, longname, stdname, units) + + name = 'Fogg_rofi' + call seq_flds_add(g2x_fluxes,trim(name)) + longname = 'glc frozen runoff flux to ocean' + stdname = 'glacier_frozen_runoff_flux_to_ocean' + units = 'kg m-2 s-1' + attname = 'Fogg_rofi' + call metadata_set(attname, longname, stdname, units) + + name = 'Figg_rofi' + call seq_flds_add(g2x_fluxes,trim(name)) + longname = 'glc frozen runoff_iceberg flux to ice' + stdname = 'glacier_frozen_runoff_flux_to_seaice' + units = 'kg m-2 s-1' + attname = 'Figg_rofi' + call metadata_set(attname, longname, stdname, units) + + name = 'Sg_icemask' + call seq_flds_add(g2x_states,trim(name)) + call seq_flds_add(g2x_states_to_lnd,trim(name)) + call seq_flds_add(x2l_states,trim(name)) + call seq_flds_add(x2l_states_from_glc,trim(name)) + longname = 'Ice sheet grid coverage on global grid' + stdname = 'ice_sheet_grid_mask' + units = '1' + attname = 'Sg_icemask' + call metadata_set(attname, longname, stdname, units) + + name = 'Sg_icemask_coupled_fluxes' + call seq_flds_add(g2x_states,trim(name)) + call seq_flds_add(g2x_states_to_lnd,trim(name)) + call seq_flds_add(x2l_states,trim(name)) + call seq_flds_add(x2l_states_from_glc,trim(name)) + longname = 'Ice sheet mask where we are potentially sending non-zero fluxes' + stdname = 'icemask_coupled_fluxes' + units = '1' + attname = 'Sg_icemask_coupled_fluxes' + call metadata_set(attname, longname, stdname, units) + + ! glc fields with multiple elevation classes: lnd->glc + ! + ! Note that these fields are sent in multiple elevation classes from lnd->cpl, but + ! the fields sent from cpl->glc do NOT have elevation classes + ! + ! Also note that we need to keep track of the l2x fields destined for glc in the + ! additional variables, l2x_fluxes_to_glc and l2x_states_to_glc. This is needed so that + ! we can set up an additional attribute vector holding accumulated quantities of just + ! these fields. (We can't determine these field lists with a call to + ! mct_aVect_initSharedFields, because the field names differ between l2x and x2g.) + + name = 'Flgl_qice' + longname = 'New glacier ice flux' + stdname = 'ice_flux_out_of_glacier' + units = 'kg m-2 s-1' + attname = 'Flgl_qice' + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_fluxes) + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_fluxes_to_glc, & + additional_list = .true.) + call seq_flds_add(x2g_fluxes,trim(name)) + call metadata_set(attname, longname, stdname, units) + + name = 'Sl_tsrf' + longname = 'Surface temperature of glacier' + stdname = 'surface_temperature' + units = 'deg C' + attname = 'Sl_tsrf' + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_states) + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_states_to_glc, & + additional_list = .true.) + call seq_flds_add(x2g_states,trim(name)) + call metadata_set(attname, longname, stdname, units) + + ! Sl_topo is sent from lnd -> cpl, but is NOT sent to glc (it is only used for the + ! remapping in the coupler) + name = 'Sl_topo' + longname = 'Surface height' + stdname = 'height' + units = 'm' + attname = 'Sl_topo' + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_states) + call set_glc_elevclass_field(name, attname, longname, stdname, units, l2x_states_to_glc, & + additional_list = .true.) + + ! glc fields with multiple elevation classes: glc->lnd + ! + ! Note that the fields sent from glc->cpl do NOT have elevation classes, but the + ! fields from cpl->lnd are broken into multiple elevation classes + + name = 'Sg_ice_covered' + longname = 'Fraction of glacier area' + stdname = 'glacier_area_fraction' + units = '1' + attname = 'Sg_ice_covered' + call seq_flds_add(g2x_states,trim(name)) + call seq_flds_add(g2x_states_to_lnd,trim(name)) + call metadata_set(attname, longname, stdname, units) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_states) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_states_from_glc, & + additional_list = .true.) + + name = 'Sg_topo' + longname = 'Surface height of glacier' + stdname = 'height' + units = 'm' + attname = 'Sg_topo' + call seq_flds_add(g2x_states,trim(name)) + call seq_flds_add(g2x_states_to_lnd,trim(name)) + call metadata_set(attname, longname, stdname, units) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_states) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_states_from_glc, & + additional_list = .true.) + + name = 'Flgg_hflx' + longname = 'Downward heat flux from glacier interior' + stdname = 'downward_heat_flux_in_glacier' + units = 'W m-2' + attname = 'Flgg_hflx' + call seq_flds_add(g2x_fluxes,trim(name)) + call seq_flds_add(g2x_fluxes_to_lnd,trim(name)) + call metadata_set(attname, longname, stdname, units) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_fluxes) + call set_glc_elevclass_field(name, attname, longname, stdname, units, x2l_fluxes_from_glc, & + additional_list = .true.) + + ! Done glc fields + + if (flds_co2a) then + + call seq_flds_add(a2x_states, "Sa_co2prog") + call seq_flds_add(x2l_states, "Sa_co2prog") + call seq_flds_add(x2o_states, "Sa_co2prog") + longname = 'Prognostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2prog' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_states, "Sa_co2diag") + call seq_flds_add(x2l_states, "Sa_co2diag") + call seq_flds_add(x2o_states, "Sa_co2diag") + longname = 'Diagnostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2diag' + call metadata_set(attname, longname, stdname, units) + + else if (flds_co2b) then + + call seq_flds_add(a2x_states, "Sa_co2prog") + call seq_flds_add(x2l_states, "Sa_co2prog") + longname = 'Prognostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2prog' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_states, "Sa_co2diag") + call seq_flds_add(x2l_states, "Sa_co2diag") + longname = 'Diagnostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2diag' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes, "Fall_fco2_lnd") + call seq_flds_add(x2a_fluxes, "Fall_fco2_lnd") + longname = 'Surface flux of CO2 from land' + stdname = 'surface_upward_flux_of_carbon_dioxide_where_land' + units = 'moles m-2 s-1' + attname = 'Fall_fco2_lnd' + call metadata_set(attname, longname, stdname, units) + + else if (flds_co2c) then + + call seq_flds_add(a2x_states, "Sa_co2prog") + call seq_flds_add(x2l_states, "Sa_co2prog") + call seq_flds_add(x2o_states, "Sa_co2prog") + longname = 'Prognostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2prog' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_states, "Sa_co2diag") + call seq_flds_add(x2l_states, "Sa_co2diag") + call seq_flds_add(x2o_states, "Sa_co2diag") + longname = 'Diagnostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2diag' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes, "Fall_fco2_lnd") + call seq_flds_add(x2a_fluxes, "Fall_fco2_lnd") + longname = 'Surface flux of CO2 from land' + stdname = 'surface_upward_flux_of_carbon_dioxide_where_land' + units = 'moles m-2 s-1' + attname = 'Fall_foc2_lnd' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(o2x_fluxes, "Faoo_fco2_ocn") + call seq_flds_add(x2a_fluxes, "Faoo_fco2_ocn") + longname = 'Surface flux of CO2 from ocean' + stdname = 'surface_upward_flux_of_carbon_dioxide_where_open_sea' + units = 'moles m-2 s-1' + attname = 'Faoo_fco2_ocn' + call metadata_set(attname, longname, stdname, units) + + else if (flds_co2_dmsa) then + + call seq_flds_add(a2x_states, "Sa_co2prog") + call seq_flds_add(x2l_states, "Sa_co2prog") + longname = 'Prognostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2prog' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_states, "Sa_co2diag") + call seq_flds_add(x2l_states, "Sa_co2diag") + longname = 'Diagnostic CO2 at the lowest model level' + stdname = '' + units = '1e-6 mol/mol' + attname = 'Sa_co2diag' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(o2x_fluxes, "Faoo_fdms_ocn") + call seq_flds_add(x2a_fluxes, "Faoo_fdms_ocn") + longname = 'Surface flux of DMS' + stdname = 'surface_upward_flux_of_dimethyl_sulfide' + units = 'moles m-2 s-1' + attname = 'Faoo_fdms' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes, "Fall_fco2_lnd") + call seq_flds_add(x2a_fluxes, "Fall_fco2_lnd") + longname = 'Surface flux of CO2 from land' + stdname = 'surface_upward_flux_of_carbon_dioxide_where_land' + units = 'moles m-2 s-1' + attname = 'Fall_foc2_lnd' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(o2x_fluxes, "Faoo_fco2_ocn") + call seq_flds_add(x2a_fluxes, "Faoo_fco2_ocn") + longname = 'Surface flux of CO2 from ocean' + stdname = 'surface_upward_flux_of_carbon_dioxide_where_open_sea' + units = 'moles m-2 s-1' + attname = 'Faoo_fco2_ocn' + call metadata_set(attname, longname, stdname, units) + + endif + + if (flds_wiso) then + call seq_flds_add(o2x_states, "So_roce_16O") + call seq_flds_add(x2i_states, "So_roce_16O") + longname = 'Ratio of ocean surface level abund. H2_16O/H2O/Rstd' + stdname = '' + units = ' ' + attname = 'So_roce_16O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(o2x_states, "So_roce_18O") + call seq_flds_add(x2i_states, "So_roce_18O") + longname = 'Ratio of ocean surface level abund. H2_18O/H2O/Rstd' + attname = 'So_roce_18O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(o2x_states, "So_roce_HDO") + call seq_flds_add(x2i_states, "So_roce_HDO") + longname = 'Ratio of ocean surface level abund. HDO/H2O/Rstd' + attname = 'So_roce_HDO' + call metadata_set(attname, longname, stdname, units) + + !-------------------------------------------- + !Atmospheric specific humidty at lowest level: + !-------------------------------------------- + + ! specific humidity of H216O at the lowest model level (kg/kg) + call seq_flds_add(a2x_states,"Sa_shum_16O") + call seq_flds_add(x2l_states,"Sa_shum_16O") + call seq_flds_add(x2i_states,"Sa_shum_16O") + longname = 'Specific humidty of H216O at the lowest model level' + stdname = 'H216OV' + units = 'kg kg-1' + attname = 'Sa_shum_16O' + call metadata_set(attname, longname, stdname, units) + + ! specific humidity of HD16O at the lowest model level (kg/kg) + call seq_flds_add(a2x_states,"Sa_shum_HDO") + call seq_flds_add(x2l_states,"Sa_shum_HDO") + call seq_flds_add(x2i_states,"Sa_shum_HDO") + longname = 'Specific humidty of HD16O at the lowest model level' + stdname = 'HD16OV' + attname = 'Sa_shum_HDO' + call metadata_set(attname, longname, stdname, units) + + ! specific humidity of H218O at the lowest model level (kg/kg) + call seq_flds_add(a2x_states,"Sa_shum_18O") + call seq_flds_add(x2l_states,"Sa_shum_18O") + call seq_flds_add(x2i_states,"Sa_shum_18O") + longname = 'Specific humidty of H218O at the lowest model level' + stdname = 'H218OV' + attname = 'Sa_shum_18O' + call metadata_set(attname, longname, stdname, units) + + ! Surface snow water equivalent (land/atm only) + call seq_flds_add(l2x_states,"Sl_snowh_16O") + call seq_flds_add(l2x_states,"Sl_snowh_18O") + call seq_flds_add(l2x_states,"Sl_snowh_HDO") + call seq_flds_add(x2a_states,"Sl_snowh_16O") + call seq_flds_add(x2a_states,"Sl_snowh_18O") + call seq_flds_add(x2a_states,"Sl_snowh_HDO") + longname = 'Isotopic surface snow water equivalent' + stdname = 'surface_snow_water_equivalent' + units = 'm' + attname = 'Sl_snowh_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_snowh_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_snowh_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_snowh_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_snowh_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_snowh_HDO' + call metadata_set(attname, longname, stdname, units) + + !-------------- + !Isotopic Rain: + !-------------- + + !Isotopic Precipitation Fluxes: + units = 'kg m-2 s-1' + call seq_flds_add(a2x_fluxes,"Faxa_rainc_16O") + call seq_flds_add(a2x_fluxes,"Faxa_rainl_16O") + call seq_flds_add(x2o_fluxes, "Faxa_rain_16O") + call seq_flds_add(x2l_fluxes,"Faxa_rainc_16O") + call seq_flds_add(x2l_fluxes,"Faxa_rainl_16O") + call seq_flds_add(x2i_fluxes, "Faxa_rain_16O") + longname = 'Water flux due to H216O rain' !equiv. to bulk + stdname = 'H2_16O_rainfall_flux' + attname = 'Faxa_rain_16O' + call metadata_set(attname, longname, stdname, units) + longname = 'H216O Convective precipitation rate' + stdname = 'H2_16O_convective_precipitation_flux' + attname = 'Faxa_rainc_16O' + call metadata_set(attname, longname, stdname, units) + longname = 'H216O Large-scale (stable) precipitation rate' + stdname = 'H2_16O_large_scale_precipitation_flux' + attname = 'Faxa_rainl_16O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_fluxes,"Faxa_rainc_18O") + call seq_flds_add(a2x_fluxes,"Faxa_rainl_18O") + call seq_flds_add(x2o_fluxes, "Faxa_rain_18O") + call seq_flds_add(x2l_fluxes,"Faxa_rainc_18O") + call seq_flds_add(x2l_fluxes,"Faxa_rainl_18O") + call seq_flds_add(x2i_fluxes, "Faxa_rain_18O") + longname = 'Water flux due to H218O rain' + stdname = 'h2_18o_rainfall_flux' + attname = 'Faxa_rain_18O' + call metadata_set(attname, longname, stdname, units) + longname = 'H218O Convective precipitation rate' + stdname = 'H2_18O_convective_precipitation_flux' + attname = 'Faxa_rainc_18O' + call metadata_set(attname, longname, stdname, units) + longname = 'H218O Large-scale (stable) precipitation rate' + stdname = 'H2_18O_large_scale_precipitation_flux' + attname = 'Faxa_rainl_18O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_fluxes,"Faxa_rainc_HDO") + call seq_flds_add(a2x_fluxes,"Faxa_rainl_HDO") + call seq_flds_add(x2o_fluxes, "Faxa_rain_HDO") + call seq_flds_add(x2l_fluxes,"Faxa_rainc_HDO") + call seq_flds_add(x2l_fluxes,"Faxa_rainl_HDO") + call seq_flds_add(x2i_fluxes, "Faxa_rain_HDO") + longname = 'Water flux due to HDO rain' + stdname = 'hdo_rainfall_flux' + attname = 'Faxa_rain_HDO' + call metadata_set(attname, longname, stdname, units) + longname = 'HDO Convective precipitation rate' + stdname = 'HDO_convective_precipitation_flux' + attname = 'Faxa_rainc_HDO' + call metadata_set(attname, longname, stdname, units) + longname = 'HDO Large-scale (stable) precipitation rate' + stdname = 'HDO_large_scale_precipitation_flux' + attname = 'Faxa_rainl_HDO' + call metadata_set(attname, longname, stdname, units) + + !------------- + !Isotopic snow: + !------------- + + call seq_flds_add(a2x_fluxes,"Faxa_snowc_16O") + call seq_flds_add(a2x_fluxes,"Faxa_snowl_16O") + call seq_flds_add(x2o_fluxes, "Faxa_snow_16O") + call seq_flds_add(x2l_fluxes,"Faxa_snowc_16O") + call seq_flds_add(x2l_fluxes,"Faxa_snowl_16O") + call seq_flds_add(x2i_fluxes, "Faxa_snow_16O") + longname = 'Water equiv. H216O snow flux' + stdname = 'h2_16o_snowfall_flux' + attname = 'Faxa_snow_16O' + call metadata_set(attname, longname, stdname, units) + longname = 'H2_16O Convective snow rate (water equivalent)' + stdname = 'H2_16O_convective_snowfall_flux' + attname = 'Faxa_snowc_16O' + call metadata_set(attname, longname, stdname, units) + longname = 'H2_16O Large-scale (stable) snow rate (water equivalent)' + stdname = 'H2_16O_large_scale_snowfall_flux' + attname = 'Faxa_snowl_16O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_fluxes,"Faxa_snowc_18O") + call seq_flds_add(a2x_fluxes,"Faxa_snowl_18O") + call seq_flds_add(x2o_fluxes, "Faxa_snow_18O") + call seq_flds_add(x2l_fluxes,"Faxa_snowc_18O") + call seq_flds_add(x2l_fluxes,"Faxa_snowl_18O") + call seq_flds_add(x2i_fluxes, "Faxa_snow_18O") + longname = 'Isotopic water equiv. snow flux of H218O' + stdname = 'h2_18o_snowfall_flux' + attname = 'Faxa_snow_18O' + call metadata_set(attname, longname, stdname, units) + longname = 'H2_18O Convective snow rate (water equivalent)' + stdname = 'H2_18O_convective_snowfall_flux' + attname = 'Faxa_snowc_18O' + call metadata_set(attname, longname, stdname, units) + longname = 'H2_18O Large-scale (stable) snow rate (water equivalent)' + stdname = 'H2_18O_large_scale_snowfall_flux' + attname = 'Faxa_snowl_18O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(a2x_fluxes,"Faxa_snowc_HDO") + call seq_flds_add(a2x_fluxes,"Faxa_snowl_HDO") + call seq_flds_add(x2o_fluxes, "Faxa_snow_HDO") + call seq_flds_add(x2l_fluxes,"Faxa_snowc_HDO") + call seq_flds_add(x2l_fluxes,"Faxa_snowl_HDO") + call seq_flds_add(x2i_fluxes, "Faxa_snow_HDO") + longname = 'Isotopic water equiv. snow flux of HDO' + stdname = 'hdo_snowfall_flux' + attname = 'Faxa_snow_HDO' + call metadata_set(attname, longname, stdname, units) + longname = 'HDO Convective snow rate (water equivalent)' + stdname = 'HDO_convective_snowfall_flux' + attname = 'Faxa_snowc_HDO' + call metadata_set(attname, longname, stdname, units) + longname = 'HDO Large-scale (stable) snow rate (water equivalent)' + stdname = 'HDO_large_scale_snowfall_flux' + attname = 'Faxa_snowl_HDO' + call metadata_set(attname, longname, stdname, units) + + !---------------------------------- + !Isotopic precipitation (rain+snow): + !---------------------------------- + + call seq_flds_add(x2o_fluxes,"Faxa_prec_16O") ! derived rain+snow + longname = 'Isotopic Water flux (rain+snow) for H2_16O' + stdname = 'h2_18o_precipitation_flux' + attname = 'Faxa_prec_16O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(x2o_fluxes,"Faxa_prec_18O") ! derived rain+snow + longname = 'Isotopic Water flux (rain+snow) for H2_18O' + stdname = 'h2_18o_precipitation_flux' + units = 'kg m-2 s-1' + attname = 'Faxa_prec_18O' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(x2o_fluxes,"Faxa_prec_HDO") ! derived rain+snow + longname = 'Isotopic Water flux (rain+snow) for HD_O' + stdname = 'hdo_precipitation_flux' + units = 'kg m-2 s-1' + attname = 'Faxa_prec_HDO' + call metadata_set(attname, longname, stdname, units) + + !------------------------------------- + !Isotopic two meter reference humidity: + !------------------------------------- + + ! H216O Reference specific humidity at 2 meters + call seq_flds_add(l2x_states,"Sl_qref_16O") + call seq_flds_add(i2x_states,"Si_qref_16O") + call seq_flds_add(xao_states,"So_qref_16O") + call seq_flds_add(x2a_states,"Sx_qref_16O") + longname = 'Reference H216O specific humidity at 2 meters' + stdname = 'H216O_specific_humidity' + units = 'kg kg-1' + attname = 'Si_qref_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_qref_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'So_qref_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_qref_16O' + call metadata_set(attname, longname, stdname, units) + + ! HD16O Reference specific humidity at 2 meters + call seq_flds_add(l2x_states,"Sl_qref_HDO") + call seq_flds_add(i2x_states,"Si_qref_HDO") + call seq_flds_add(xao_states,"So_qref_HDO") + call seq_flds_add(x2a_states,"Sx_qref_HDO") + longname = 'Reference HD16O specific humidity at 2 meters' + stdname = 'HD16O_specific_humidity' + units = 'kg kg-1' + attname = 'Si_qref_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_qref_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'So_qref_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_qref_HDO' + call metadata_set(attname, longname, stdname, units) + + ! H218O Reference specific humidity at 2 meters + call seq_flds_add(l2x_states,"Sl_qref_18O") + call seq_flds_add(i2x_states,"Si_qref_18O") + call seq_flds_add(xao_states,"So_qref_18O") + call seq_flds_add(x2a_states,"Sx_qref_18O") + longname = 'Reference H218O specific humidity at 2 meters' + stdname = 'H218O_specific_humidity' + units = 'kg kg-1' + attname = 'Si_qref_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sl_qref_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'So_qref_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Sx_qref_18O' + call metadata_set(attname, longname, stdname, units) + + !------------------------- + !Isotopic Evaporation flux: + !------------------------- + + ! H216O Evaporation water flux + call seq_flds_add(l2x_fluxes,"Fall_evap_16O") + call seq_flds_add(i2x_fluxes,"Faii_evap_16O") + call seq_flds_add(xao_fluxes,"Faox_evap_16O") + call seq_flds_add(x2a_fluxes,"Faxx_evap_16O") + call seq_flds_add(x2o_fluxes,"Foxx_evap_16O") + longname = 'Evaporation H216O flux' + stdname = 'H216O_evaporation_flux' + units = 'kg m-2 s-1' + attname = 'Fall_evap_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_evap_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_evap_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_evap_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_evap_16O' + call metadata_set(attname, longname, stdname, units) + + ! HD16O Evaporation water flux + call seq_flds_add(l2x_fluxes,"Fall_evap_HDO") + call seq_flds_add(i2x_fluxes,"Faii_evap_HDO") + call seq_flds_add(xao_fluxes,"Faox_evap_HDO") + call seq_flds_add(x2a_fluxes,"Faxx_evap_HDO") + call seq_flds_add(x2o_fluxes,"Foxx_evap_HDO") + longname = 'Evaporation HD16O flux' + stdname = 'HD16O_evaporation_flux' + units = 'kg m-2 s-1' + attname = 'Fall_evap_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_evap_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_evap_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_evap_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_evap_HDO' + call metadata_set(attname, longname, stdname, units) + + ! H218O Evaporation water flux + call seq_flds_add(l2x_fluxes,"Fall_evap_18O") + call seq_flds_add(i2x_fluxes,"Faii_evap_18O") + call seq_flds_add(xao_fluxes,"Faox_evap_18O") + call seq_flds_add(x2a_fluxes,"Faxx_evap_18O") + call seq_flds_add(x2o_fluxes,"Foxx_evap_18O") + longname = 'Evaporation H218O flux' + stdname = 'H218O_evaporation_flux' + units = 'kg m-2 s-1' + attname = 'Fall_evap_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faii_evap_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faox_evap_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Faxx_evap_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_evap_18O' + call metadata_set(attname, longname, stdname, units) + + !----------------------------- + !Isotopic sea ice melting flux: + !----------------------------- + + ! H216O Water flux from melting + units = 'kg m-2 s-1' + call seq_flds_add(i2x_fluxes,"Fioi_meltw_16O") + call seq_flds_add(x2o_fluxes,"Fioi_meltw_16O") + longname = 'H2_16O flux due to melting' + stdname = 'h2_16o_surface_snow_melt_flux' + attname = 'Fioi_meltw_16O' + call metadata_set(attname, longname, stdname, units) + + ! H218O Water flux from melting + call seq_flds_add(i2x_fluxes,"Fioi_meltw_18O") + call seq_flds_add(x2o_fluxes,"Fioi_meltw_18O") + longname = 'H2_18O flux due to melting' + stdname = 'h2_18o_surface_snow_melt_flux' + attname = 'Fioi_meltw_18O' + call metadata_set(attname, longname, stdname, units) + + ! HDO Water flux from melting + units = 'kg m-2 s-1' + call seq_flds_add(i2x_fluxes,"Fioi_meltw_HDO") + call seq_flds_add(x2o_fluxes,"Fioi_meltw_HDO") + longname = 'HDO flux due to melting' + stdname = 'hdo_surface_snow_melt_flux' + attname = 'Fioi_meltw_HDO' + call metadata_set(attname, longname, stdname, units) + + !Iso-Runoff + ! r2o, l2x, x2r + + units = 'kg m-2 s-1' + call seq_flds_add(l2x_fluxes,'Flrl_rofi_16O') + call seq_flds_add(x2r_fluxes,'Flrl_rofi_16O') + longname = 'H2_16O Water flux from land (frozen)' + stdname = 'H2_16O_frozen_water_flux_into_runoff' + attname = 'Flrl_rofi_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(l2x_fluxes,'Flrl_rofi_18O') + call seq_flds_add(x2r_fluxes,'Flrl_rofi_18O') + longname = 'H2_18O Water flux from land (frozen)' + stdname = 'H2_18O_frozen_water_flux_into_runoff' + attname = 'Flrl_rofi_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(l2x_fluxes,'Flrl_rofi_HDO') + call seq_flds_add(x2r_fluxes,'Flrl_rofi_HDO') + longname = 'HDO Water flux from land (frozen)' + stdname = 'HDO_frozen_water_flux_into_runoff' + attname = 'Flrl_rofi_HDO' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(l2x_fluxes,'Flrl_rofl_16O') + call seq_flds_add(x2r_fluxes,'Flrl_rofl_16O') + longname = 'H2_16O Water flux from land (liquid)' + stdname = 'H2_16O_liquid_water_flux_into_runoff' + attname = 'Flrl_rofl_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(l2x_fluxes,'Flrl_rofl_18O') + call seq_flds_add(x2r_fluxes,'Flrl_rofl_18O') + longname = 'H2_18O Water flux from land (liquid)' + stdname = 'H2_18O_liquid_water_flux_into_runoff' + attname = 'Flrl_rofl_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(l2x_fluxes,'Flrl_rofl_HDO') + call seq_flds_add(x2r_fluxes,'Flrl_rofl_HDO') + longname = 'HDO Water flux from land (liquid)' + stdname = 'HDO_liquid_water_flux_into_runoff' + attname = 'Flrl_rofl_HDO' + call metadata_set(attname, longname, stdname, units) + + ! r2x, x2o + call seq_flds_add(r2x_fluxes,'Forr_rofl_16O') + call seq_flds_add(x2o_fluxes,'Foxx_rofl_16O') + call seq_flds_add(r2o_liq_fluxes,'Forr_rofl_16O') + longname = 'H2_16O Water flux due to liq runoff ' + stdname = 'H2_16O_water_flux_into_sea_water' + attname = 'Forr_rofl_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofl_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Forr_rofl_18O') + call seq_flds_add(x2o_fluxes,'Foxx_rofl_18O') + call seq_flds_add(r2o_liq_fluxes,'Forr_rofl_18O') + longname = 'H2_18O Water flux due to liq runoff ' + stdname = 'H2_18O_water_flux_into_sea_water' + attname = 'Forr_rofl_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofl_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Forr_rofl_HDO') + call seq_flds_add(x2o_fluxes,'Foxx_rofl_HDO') + call seq_flds_add(r2o_liq_fluxes,'Forr_rofl_HDO') + longname = 'HDO Water flux due to liq runoff ' + stdname = 'HDO_water_flux_into_sea_water' + attname = 'Forr_rofl_HDO' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofl_HDO' + call metadata_set(attname, longname, stdname, units) + + call seq_flds_add(r2x_fluxes,'Forr_rofi_16O') + call seq_flds_add(x2o_fluxes,'Foxx_rofi_16O') + call seq_flds_add(r2o_ice_fluxes,'Forr_rofi_16O') + longname = 'H2_16O Water flux due to ice runoff ' + stdname = 'H2_16O_water_flux_into_sea_water' + attname = 'Forr_rofi_16O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofi_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Forr_rofi_18O') + call seq_flds_add(x2o_fluxes,'Foxx_rofi_18O') + call seq_flds_add(r2o_ice_fluxes,'Forr_rofi_18O') + longname = 'H2_18O Water flux due to ice runoff ' + stdname = 'H2_18O_water_flux_into_sea_water' + attname = 'Forr_rofi_18O' + call metadata_set(attname, longname, stdname, units) + attname = 'Foxx_rofi_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Forr_rofi_HDO') + call seq_flds_add(x2o_fluxes,'Foxx_rofi_HDO') + call seq_flds_add(r2o_ice_fluxes,'Forr_rofi_HDO') + longname = 'HDO Water flux due to ice runoff ' + stdname = 'HDO_water_flux_into_sea_water' + attname = 'Forr_rofi_HDO' + call metadata_set(attname, longname, stdname, units) + + ! r2x, x2l + call seq_flds_add(r2x_fluxes,'Flrr_flood_16O') + call seq_flds_add(x2l_fluxes,'Flrr_flood_16O') + longname = 'H2_16O waterrflux due to flooding' + stdname = 'H2_16O_flodding_water_flux_back_to_land' + attname = 'Flrr_flood_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Flrr_flood_18O') + call seq_flds_add(x2l_fluxes,'Flrr_flood_18O') + longname = 'H2_18O waterrflux due to flooding' + stdname = 'H2_18O_flodding_water_flux_back_to_land' + attname = 'Flrr_flood_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_fluxes,'Flrr_flood_HDO') + call seq_flds_add(x2l_fluxes,'Flrr_flood_HDO') + longname = 'HDO Waterrflux due to flooding' + stdname = 'HDO_flodding_water_flux_back_to_land' + attname = 'Flrr_flood_HDO' + call metadata_set(attname, longname, stdname, units) + + units = 'm3' + call seq_flds_add(r2x_states,'Flrr_volr_16O') + call seq_flds_add(x2l_states,'Flrr_volr_16O') + longname = 'H2_16O river channel water volume ' + stdname = 'H2_16O_rtm_volr' + attname = 'Flrr_volr_16O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_states,'Flrr_volr_18O') + call seq_flds_add(x2l_states,'Flrr_volr_18O') + longname = 'H2_18O river channel water volume ' + stdname = 'H2_18O_rtm_volr' + attname = 'Flrr_volr_18O' + call metadata_set(attname, longname, stdname, units) + call seq_flds_add(r2x_states,'Flrr_volr_HDO') + call seq_flds_add(x2l_states,'Flrr_volr_HDO') + longname = 'HDO river channel water volume ' + stdname = 'HDO_rtm_volr' + attname = 'Flrr_volr_HDO' + call metadata_set(attname, longname, stdname, units) + + ! call seq_flds_add(r2x_fluxes,'Flrr_flood_HDO') + ! call seq_flds_add(x2l_fluxes,'Flrr_flood_HDO') + ! longname = 'H2_18O Waterrflux due to flooding' + ! stdname = 'H2_18O_flodding_water_flux_back_to_land' + ! attname = 'Flrr_flood_18O' + ! call metadata_set(attname, longname, stdname, units) + + !----------------------------- + + endif !Water isotopes + + !----------------------------------------------------------------------------- + ! optional per thickness category fields + !----------------------------------------------------------------------------- + + if (seq_flds_i2o_per_cat) then + do num = 1, ice_ncat + write(cnum,'(i2.2)') num + + ! Fractional ice coverage wrt ocean + + name = 'Si_ifrac_' // cnum + call seq_flds_add(i2x_states,name) + call seq_flds_add(x2o_states,name) + longname = 'fractional ice coverage wrt ocean for thickness category ' // cnum + stdname = 'sea_ice_area_fraction' + units = '1' + attname = name + call metadata_set(attname, longname, stdname, units) + + ! Net shortwave radiation + + name = 'PFioi_swpen_ifrac_' // cnum + call seq_flds_add(i2x_fluxes,name) + call seq_flds_add(x2o_fluxes,name) + longname = 'net shortwave radiation penetrating into ice and ocean times ice fraction for thickness category ' // cnum + stdname = 'product_of_net_downward_shortwave_flux_at_sea_water_surface_and_sea_ice_area_fraction' + units = 'W m-2' + attname = name + call metadata_set(attname, longname, stdname, units) + + end do + + ! Fractional atmosphere coverage wrt ocean + + name = 'Sf_afrac' + call seq_flds_add(x2o_states,name) + longname = 'fractional atmosphere coverage wrt ocean' + stdname = 'atmosphere_area_fraction' + units = '1' + attname = name + call metadata_set(attname, longname, stdname, units) + + name = 'Sf_afracr' + call seq_flds_add(x2o_states,name) + longname = 'fractional atmosphere coverage used in radiation computations wrt ocean' + stdname = 'atmosphere_area_fraction' + units = '1' + attname = name + call metadata_set(attname, longname, stdname, units) + + ! Net shortwave radiation + + name = 'Foxx_swnet_afracr' + call seq_flds_add(x2o_fluxes,name) + longname = 'net shortwave radiation times atmosphere fraction' + stdname = 'product_of_net_downward_shortwave_flux_at_sea_water_surface_and_atmosphere_area_fraction' + units = 'W m-2' + attname = name + call metadata_set(attname, longname, stdname, units) + endif + + !----------------------------------------------------------------------------- + ! Read namelist for CARMA + ! if carma_flds are specified then setup fields for CLM to CAM communication + !----------------------------------------------------------------------------- + + call shr_carma_readnl(nlfilename='drv_flds_in', carma_fields=carma_fields) + if (carma_fields /= ' ') then + call seq_flds_add(l2x_fluxes, trim(carma_fields)) + call seq_flds_add(x2a_fluxes, trim(carma_fields)) + longname = 'Volumetric soil water' + stdname = 'soil_water' + units = 'm3/m3' + call metadata_set(carma_fields, longname, stdname, units) + endif + + !----------------------------------------------------------------------------- + ! Read namelist for MEGAN + ! if MEGAN emission are specified then setup fields for CLM to CAM communication + ! (emissions fluxes) + !----------------------------------------------------------------------------- + + call shr_megan_readnl(nlfilename='drv_flds_in', ID=ID, megan_fields=megan_voc_fields) + if (shr_megan_mechcomps_n>0) then + call seq_flds_add(l2x_fluxes, trim(megan_voc_fields)) + call seq_flds_add(x2a_fluxes, trim(megan_voc_fields)) + longname = 'MEGAN emission fluxes' + stdname = 'megan_fluxes' + units = 'molecules/m2/sec' + call metadata_set(megan_voc_fields, longname, stdname, units) + endif + + !----------------------------------------------------------------------------- + ! Read namelist for Fire Emissions + ! if fire emission are specified then setup fields for CLM to CAM communication + ! (emissions fluxes) + !----------------------------------------------------------------------------- + + call shr_fire_emis_readnl(nlfilename='drv_flds_in', ID=ID, emis_fields=fire_emis_fields) + if (shr_fire_emis_mechcomps_n>0) then + call seq_flds_add(l2x_fluxes, trim(fire_emis_fields)) + call seq_flds_add(x2a_fluxes, trim(fire_emis_fields)) + longname = 'wild fire emission fluxes' + stdname = 'fire_emis' + units = 'kg/m2/sec' + call metadata_set(fire_emis_fields, longname, stdname, units) + + call seq_flds_add(l2x_states, trim(shr_fire_emis_ztop_token)) + call seq_flds_add(x2a_states, trim(shr_fire_emis_ztop_token)) + longname = 'wild fire plume height' + stdname = 'fire_plume_top' + units = 'm' + + call metadata_set(shr_fire_emis_ztop_token, longname, stdname, units) + endif + + !----------------------------------------------------------------------------- + ! Dry Deposition fields + ! First read namelist and figure out the drydep field list to pass + ! Then check if file exists and if not, n_drydep will be zero + ! Then add dry deposition fields to land export and atmosphere import states + ! Then initialize dry deposition fields + ! Note: CAM and CLM will then call seq_drydep_setHCoeff + !----------------------------------------------------------------------------- + + call seq_drydep_readnl(nlfilename="drv_flds_in", ID=ID, seq_drydep_fields=seq_drydep_fields) + if ( lnd_drydep ) then + call seq_flds_add(l2x_states, seq_drydep_fields) + call seq_flds_add(x2a_states, seq_drydep_fields) + + longname = 'dry deposition velocity' + stdname = 'drydep_vel' + units = 'cm/sec' + + call metadata_set(seq_drydep_fields, longname, stdname, units) + endif + call seq_drydep_init( ) + + !----------------------------------------------------------------------------- + ! Nitrogen Deposition fields + ! First read namelist and figure out the ndepdep field list to pass + ! Then check if file exists and if not, n_drydep will be zero + ! Then add nitrogen deposition fields to atm export, lnd import and ocn import + !----------------------------------------------------------------------------- + + call shr_ndep_readnl(nlfilename="drv_flds_in", ID=ID, ndep_fields=ndep_fields, add_ndep_fields=add_ndep_fields) + if (add_ndep_fields) then + call seq_flds_add(a2x_fluxes, ndep_fields) + call seq_flds_add(x2l_fluxes, ndep_fields) + call seq_flds_add(x2o_fluxes, ndep_fields) + + longname = 'nitrogen deposition flux' + stdname = 'nitrogen_deposition' + units = 'kg(N)/m2/sec' + + call metadata_set(ndep_fields, longname, stdname, units) + end if + + !---------------------------------------------------------------------------- + ! state + flux fields + !---------------------------------------------------------------------------- + + seq_flds_dom_coord = trim(dom_coord ) + seq_flds_a2x_states = trim(a2x_states) + seq_flds_x2a_states = trim(x2a_states) + seq_flds_i2x_states = trim(i2x_states) + seq_flds_x2i_states = trim(x2i_states) + seq_flds_l2x_states = trim(l2x_states) + seq_flds_l2x_states_to_glc = trim(l2x_states_to_glc) + seq_flds_x2l_states = trim(x2l_states) + seq_flds_x2l_states_from_glc = trim(x2l_states_from_glc) + seq_flds_o2x_states = trim(o2x_states) + seq_flds_x2o_states = trim(x2o_states) + seq_flds_g2x_states = trim(g2x_states) + seq_flds_g2x_states_to_lnd = trim(g2x_states_to_lnd) + seq_flds_x2g_states = trim(x2g_states) + seq_flds_xao_states = trim(xao_states) + seq_flds_xao_albedo = trim(xao_albedo) + seq_flds_xao_diurnl = trim(xao_diurnl) + seq_flds_r2x_states = trim(r2x_states) + seq_flds_x2r_states = trim(x2r_states) + seq_flds_w2x_states = trim(w2x_states) + seq_flds_x2w_states = trim(x2w_states) + + seq_flds_dom_other = trim(dom_other ) + seq_flds_a2x_fluxes = trim(a2x_fluxes) + seq_flds_x2a_fluxes = trim(x2a_fluxes) + seq_flds_i2x_fluxes = trim(i2x_fluxes) + seq_flds_x2i_fluxes = trim(x2i_fluxes) + seq_flds_l2x_fluxes = trim(l2x_fluxes) + seq_flds_l2x_fluxes_to_glc = trim(l2x_fluxes_to_glc) + seq_flds_x2l_fluxes = trim(x2l_fluxes) + seq_flds_x2l_fluxes_from_glc = trim(x2l_fluxes_from_glc) + seq_flds_o2x_fluxes = trim(o2x_fluxes) + seq_flds_x2o_fluxes = trim(x2o_fluxes) + seq_flds_g2x_fluxes = trim(g2x_fluxes) + seq_flds_g2x_fluxes_to_lnd = trim(g2x_fluxes_to_lnd) + seq_flds_x2g_fluxes = trim(x2g_fluxes) + seq_flds_xao_fluxes = trim(xao_fluxes) + seq_flds_r2x_fluxes = trim(r2x_fluxes) + seq_flds_x2r_fluxes = trim(x2r_fluxes) + seq_flds_w2x_fluxes = trim(w2x_fluxes) + seq_flds_x2w_fluxes = trim(x2w_fluxes) + seq_flds_r2o_liq_fluxes = trim(r2o_liq_fluxes) + seq_flds_r2o_ice_fluxes = trim(r2o_ice_fluxes) + + if (seq_comm_iamroot(ID)) then + write(logunit,"(A)") subname//': seq_flds_a2x_states= ',trim(seq_flds_a2x_states) + write(logunit,"(A)") subname//': seq_flds_a2x_fluxes= ',trim(seq_flds_a2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2a_states= ',trim(seq_flds_x2a_states) + write(logunit,"(A)") subname//': seq_flds_x2a_fluxes= ',trim(seq_flds_x2a_fluxes) + write(logunit,"(A)") subname//': seq_flds_l2x_states= ',trim(seq_flds_l2x_states) + write(logunit,"(A)") subname//': seq_flds_l2x_fluxes= ',trim(seq_flds_l2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2l_states= ',trim(seq_flds_x2l_states) + write(logunit,"(A)") subname//': seq_flds_x2l_fluxes= ',trim(seq_flds_x2l_fluxes) + write(logunit,"(A)") subname//': seq_flds_i2x_states= ',trim(seq_flds_i2x_states) + write(logunit,"(A)") subname//': seq_flds_i2x_fluxes= ',trim(seq_flds_i2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2i_states= ',trim(seq_flds_x2i_states) + write(logunit,"(A)") subname//': seq_flds_x2i_fluxes= ',trim(seq_flds_x2i_fluxes) + write(logunit,"(A)") subname//': seq_flds_o2x_states= ',trim(seq_flds_o2x_states) + write(logunit,"(A)") subname//': seq_flds_o2x_fluxes= ',trim(seq_flds_o2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2o_states= ',trim(seq_flds_x2o_states) + write(logunit,"(A)") subname//': seq_flds_x2o_fluxes= ',trim(seq_flds_x2o_fluxes) + write(logunit,"(A)") subname//': seq_flds_g2x_states= ',trim(seq_flds_g2x_states) + write(logunit,"(A)") subname//': seq_flds_g2x_fluxes= ',trim(seq_flds_g2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2g_states= ',trim(seq_flds_x2g_states) + write(logunit,"(A)") subname//': seq_flds_x2g_fluxes= ',trim(seq_flds_x2g_fluxes) + write(logunit,"(A)") subname//': seq_flds_xao_states= ',trim(seq_flds_xao_states) + write(logunit,"(A)") subname//': seq_flds_xao_fluxes= ',trim(seq_flds_xao_fluxes) + write(logunit,"(A)") subname//': seq_flds_xao_albedo= ',trim(seq_flds_xao_albedo) + write(logunit,"(A)") subname//': seq_flds_xao_diurnl= ',trim(seq_flds_xao_diurnl) + write(logunit,"(A)") subname//': seq_flds_r2x_states= ',trim(seq_flds_r2x_states) + write(logunit,"(A)") subname//': seq_flds_r2x_fluxes= ',trim(seq_flds_r2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2r_states= ',trim(seq_flds_x2r_states) + write(logunit,"(A)") subname//': seq_flds_x2r_fluxes= ',trim(seq_flds_x2r_fluxes) + write(logunit,"(A)") subname//': seq_flds_w2x_states= ',trim(seq_flds_w2x_states) + write(logunit,"(A)") subname//': seq_flds_w2x_fluxes= ',trim(seq_flds_w2x_fluxes) + write(logunit,"(A)") subname//': seq_flds_x2w_states= ',trim(seq_flds_x2w_states) + write(logunit,"(A)") subname//': seq_flds_x2w_fluxes= ',trim(seq_flds_x2w_fluxes) + end if + + call catFields(seq_flds_dom_fields, seq_flds_dom_coord , seq_flds_dom_other ) + call catFields(seq_flds_a2x_fields, seq_flds_a2x_states, seq_flds_a2x_fluxes) + call catFields(seq_flds_x2a_fields, seq_flds_x2a_states, seq_flds_x2a_fluxes) + call catFields(seq_flds_i2x_fields, seq_flds_i2x_states, seq_flds_i2x_fluxes) + call catFields(seq_flds_x2i_fields, seq_flds_x2i_states, seq_flds_x2i_fluxes) + call catFields(seq_flds_l2x_fields, seq_flds_l2x_states, seq_flds_l2x_fluxes) + call catFields(seq_flds_l2x_fields_to_glc, seq_flds_l2x_states_to_glc, seq_flds_l2x_fluxes_to_glc) + call catFields(seq_flds_x2l_fields, seq_flds_x2l_states, seq_flds_x2l_fluxes) + call catFields(seq_flds_x2l_fields_from_glc, seq_flds_x2l_states_from_glc, seq_flds_x2l_fluxes_from_glc) + call catFields(seq_flds_o2x_fields, seq_flds_o2x_states, seq_flds_o2x_fluxes) + call catFields(seq_flds_x2o_fields, seq_flds_x2o_states, seq_flds_x2o_fluxes) + call catFields(seq_flds_g2x_fields, seq_flds_g2x_states, seq_flds_g2x_fluxes) + call catFields(seq_flds_g2x_fields_to_lnd, seq_flds_g2x_states_to_lnd, seq_flds_g2x_fluxes_to_lnd) + call catFields(seq_flds_x2g_fields, seq_flds_x2g_states, seq_flds_x2g_fluxes) + call catFields(seq_flds_xao_fields, seq_flds_xao_albedo, seq_flds_xao_states) + call catFields(stringtmp , seq_flds_xao_fields, seq_flds_xao_fluxes) + call catFields(seq_flds_xao_fields, stringtmp , seq_flds_xao_diurnl) + call catFields(seq_flds_r2x_fields, seq_flds_r2x_states, seq_flds_r2x_fluxes) + call catFields(seq_flds_x2r_fields, seq_flds_x2r_states, seq_flds_x2r_fluxes) + call catFields(seq_flds_w2x_fields, seq_flds_w2x_states, seq_flds_w2x_fluxes) + call catFields(seq_flds_x2w_fields, seq_flds_x2w_states, seq_flds_x2w_fluxes) + + end subroutine seq_flds_set + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_flds_add + ! + ! !DESCRIPTION: + ! Returns new concatentated field list + ! in the output character string {\tt outfld}. + ! + ! !REVISION HISTORY: + ! 2011-Nov-27 - M. Vertenstein - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_flds_add(outfld, str) + + ! !USES: + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=*),intent(in) :: str ! string + character(len=*),intent(inout) :: outfld ! output field name + + !EOP + + character(len=*),parameter :: subname = '(seq_flds_add) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (trim(outfld) == '') then + outfld = trim(str) + else + outfld = trim(outfld)//':'//trim(str) + end if + if (len_trim(outfld) >= CXX) then + write(logunit,*)'fields are = ',trim(outfld) + write(logunit,*)'fields length = ',len_trim(outfld) + call shr_sys_abort(subname//'ERROR: maximum length of xxx_states or xxx_fluxes has been exceeded') + end if + + end subroutine seq_flds_add + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: catFields + ! + ! !DESCRIPTION: + ! Returns {\tt nfld} concatentated field lists + ! in the output character string {\tt outfield}. + ! + ! !REVISION HISTORY: + ! 2003-Jan-24 - T. Craig - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine catFields(outfield, str1, str2) + + ! !USES: + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=*),intent(inout) :: outfield ! output field name + character(len=*),intent(in) :: str1 ! string1 + character(len=*),intent(in ) :: str2 ! string2 + + !EOP + + character(len=*),parameter :: subname = '(seq_flds_catFields) ' + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + outfield = '' + if (len_trim(str1) > 0 .and. len_trim(str2) > 0) then + if (len_trim(str1) + len_trim(str2) + 1 > len(outfield)) then + call shr_sys_abort(subname//' ERROR: maximum length of string has been exceeded sum') + endif + outfield = trim(str1)//':'//trim(str2) + else + if (len_trim(str1) > 0) then + if (len_trim(str1) > len(outfield)) then + call shr_sys_abort(subname//' ERROR: maximum length of string has been exceeded str1') + endif + outfield = trim(str1) + endif + if (len_trim(str2) > 0) then + if (len_trim(str2) > len(outfield)) then + call shr_sys_abort(subname//' ERROR: maximum length of string has been exceeded str2') + endif + outfield = trim(str2) + endif + endif + + end subroutine catFields + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_flds_getField + ! + ! !DESCRIPTION: + ! Returns {\tt nfld} element of the colon-delimited string {\tt cstring} + ! in the output character string {\tt outfield}. + ! + ! !REVISION HISTORY: + ! 2003-Jan-24 - T. Craig - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_flds_getField(outfield, nfld, cstring) + + ! !USES: + use mct_mod + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=*),intent(out) :: outfield ! output field name + integer ,intent(in ) :: nfld ! field number + character(len=*),intent(in ) :: cstring ! colon delimited field string + + !EOP + + type(mct_list) :: mctIstr ! mct list from input cstring + type(mct_string) :: mctOStr ! mct string for output outfield + character(len=*),parameter :: subname = '(seq_flds_getField) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + outfield = '' + + call mct_list_init(mctIstr,cstring) + call mct_list_get(mctOStr,nfld,mctIstr) + outfield = mct_string_toChar(mctOStr) + call mct_list_clean(mctIstr) + call mct_string_clean(mctOStr) + + end subroutine seq_flds_getField + + !=============================================================================== +! If the attname passed in contains colons it is assumed to be a list of fields +! all of which have the same names and units + subroutine metadata_set(attname , longname, stdname , units ) + + ! !USES: + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: attname + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: stdname + character(len=*), intent(in) :: units + + !EOP + character(len=*),parameter :: subname = '(seq_flds_metadata_set) ' + integer :: i, j + + i = index(attname,':') + j=1 + + do while(i>j .and. i<=len_trim(attname)) + n_entries = n_entries + 1 + lookup_entry(n_entries,1) = attname(j:i-1) + lookup_entry(n_entries,2) = trim(longname) + lookup_entry(n_entries,3) = trim(stdname ) + lookup_entry(n_entries,4) = trim(units ) + j=i+1 + i = index(attname(j:),':') + j - 1 + enddo + n_entries = n_entries + 1 + i = len_trim(attname) + lookup_entry(n_entries,1) = attname(j:i) + lookup_entry(n_entries,2) = trim(longname) + lookup_entry(n_entries,3) = trim(stdname ) + lookup_entry(n_entries,4) = trim(units ) + + + + + if (n_entries .ge. nmax) then + write(logunit,*)'n_entries= ',n_entries,' nmax = ',nmax,' attname= ',trim(attname) + call shr_sys_abort(subname//'ERROR: nmax fields in lookup_entry table exceeded') + end if + + end subroutine metadata_set + + !=============================================================================== + + subroutine set_glc_elevclass_field(name, attname, longname, stdname, units, fieldlist, & + additional_list) + + ! Sets a coupling field for all glc elevation classes (1:glc_nec) plus bare land + ! (index 0). + ! + ! Note that, if glc_nec = 0, then we don't create any coupling fields (not even the + ! bare land (0) index) + ! + ! Puts the coupling fields in the given fieldlist, and also does the appropriate + ! metadata_set calls. + ! + ! additional_list should be .false. (or absent) the first time this is called for a + ! given set of coupling fields. However, if this same set of coupling fields is being + ! added to multiple field lists, then additional_list should be set to true for the + ! second and subsequent calls; in this case, the metadata_set calls are not done + ! (because they have already been done). + ! + ! name, attname and longname give the base name of the field; the elevation class + ! index will be appended as a suffix + + ! !USES: + use glc_elevclass_mod, only : glc_get_num_elevation_classes, glc_elevclass_as_string + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: name ! base field name to add to fieldlist + character(len=*), intent(in) :: attname ! base field name for metadata + character(len=*), intent(in) :: longname ! base long name for metadata + character(len=*), intent(in) :: stdname ! standard name for metadata + character(len=*), intent(in) :: units ! units for metadata + character(len=*), intent(inout) :: fieldlist ! field list into which the fields should be added + + logical, intent(in), optional :: additional_list ! whether this is an additional list for the same set of coupling fields (see above for details; defaults to false) + + !EOP + integer :: num + character(len= 16) :: cnum + logical :: l_additional_list ! local version of the optional additional_list argument + + l_additional_list = .false. + if (present(additional_list)) then + l_additional_list = additional_list + end if + + if (glc_get_num_elevation_classes() > 0) then + do num = 0, glc_get_num_elevation_classes() + cnum = glc_elevclass_as_string(num) + + call seq_flds_add(fieldlist, trim(name) // trim(cnum)) + + if (.not. l_additional_list) then + call metadata_set(attname = trim(attname) // trim(cnum), & + longname = trim(longname) // ' of elevation class ' // trim(cnum), & + stdname = stdname, & + units = units) + end if + end do + end if + end subroutine set_glc_elevclass_field + + !=============================================================================== + + subroutine seq_flds_esmf_metadata_get(shortname, longname, stdname, units) + + ! !USES: + use shr_string_mod, only : shr_string_lastindex + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: shortname + character(len=*),optional, intent(out) :: longname + character(len=*),optional, intent(out) :: stdname + character(len=*),optional, intent(out) :: units + + !EOP + + !--- local --- + integer :: i,n + character(len=CSS) :: llongname, lstdname, lunits, lshortname ! local copies + character(len=*),parameter :: undef = 'undefined' + character(len=*),parameter :: unknown = 'unknown' + logical :: found + character(len=*),parameter :: subname = '(seq_flds_esmf_metadata_get) ' + + !--- define field metadata (name, long_name, standard_name, units) --- + + llongname = trim(unknown) + lstdname = trim(unknown) + lunits = trim(unknown) + + found = .false. + + if (.not.found) then + i = 1 + do while (i <= n_entries .and. .not.found) + lshortname = trim(shortname) + if (trim(lshortname) == trim(lookup_entry(i,1))) then + llongname = trim(lookup_entry(i,2)) + lstdname = trim(lookup_entry(i,3)) + lunits = trim(lookup_entry(i,4)) + found =.true. + end if + i = i + 1 + end do + endif + + if (.not.found) then + i = 1 + do while (i <= n_entries .and. .not.found) + n = shr_string_lastIndex(shortname,"_") + lshortname = "" + if (n < len_trim(shortname)) lshortname = shortname(n+1:len_trim(shortname)) + if (trim(lshortname) == trim(lookup_entry(i,1))) then + llongname = trim(lookup_entry(i,2)) + lstdname = trim(lookup_entry(i,3)) + lunits = trim(lookup_entry(i,4)) + found = .true. + end if + i = i + 1 + end do + endif + + if (present(longname)) then + longname = trim(llongname) + endif + if (present(stdname)) then + stdname = trim(lstdname) + endif + if (present(units)) then + units = trim(lunits) + endif + + end subroutine seq_flds_esmf_metadata_get + + end module seq_flds_mod diff --git a/driver-mct/shr/seq_infodata_mod.F90 b/driver-mct/shr/seq_infodata_mod.F90 new file mode 100644 index 000000000000..9a9421b54150 --- /dev/null +++ b/driver-mct/shr/seq_infodata_mod.F90 @@ -0,0 +1,2996 @@ +!=============================================================================== +! SVN $Id: seq_infodata_mod.F90 68253 2015-02-18 22:24:57Z mvertens $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/drv/seq_mct/trunk_tags/drvseq5_1_15/shr/seq_infodata_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_infodata_mod --- Module for input data shared between CCSM components +! +! !DESCRIPTION: +! +! A module to get, put, and store some standard scalar data +! +! Typical usage: +! +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2005-Nov-11 - E. Kluzek - creation of shr_inputinfo_mod +! 2007-Nov-15 - T. Craig - refactor for ccsm4 system and move to seq_infodata_mod +! 2016-Dec-08 - R. Montuoro - updated for multiple driver instances +! +! !INTERFACE: ------------------------------------------------------------------ + +MODULE seq_infodata_mod + +! !USES: + + use shr_kind_mod, only: SHR_KIND_CS, SHR_KIND_CL, SHR_KIND_IN, & + SHR_KIND_R8, SHR_KIND_I8 + use shr_sys_mod, only: shr_sys_flush, shr_sys_abort, shr_sys_getenv + use seq_comm_mct, only: logunit, loglevel, CPLID, seq_comm_gloroot + use seq_comm_mct, only: seq_comm_setptrs, seq_comm_iamroot, seq_comm_iamin + use seq_comm_mct, only: num_inst_atm, num_inst_lnd, num_inst_rof + use seq_comm_mct, only: num_inst_ocn, num_inst_ice, num_inst_glc + use seq_comm_mct, only: num_inst_wav + use shr_orb_mod, only: SHR_ORB_UNDEF_INT, SHR_ORB_UNDEF_REAL, shr_orb_params + + implicit none + + private ! default private + +! !PUBLIC TYPES: + + public :: seq_infodata_type + +! !PUBLIC MEMBER FUNCTIONS + + public :: seq_infodata_Init ! Initialize + public :: seq_infodata_Init2 ! Init after clocks initialized + public :: seq_infodata_GetData ! Get values from object + public :: seq_infodata_PutData ! Change values + public :: seq_infodata_Print ! print current info + public :: seq_infodata_Exchange ! exchange data across pes + +! !PUBLIC DATA MEMBERS: + +!EOP + + ! Strings of valid start_type options + character(len=*), public, parameter :: seq_infodata_start_type_start = "startup" + character(len=*), public, parameter :: seq_infodata_start_type_cont = "continue" + character(len=*), public, parameter :: seq_infodata_start_type_brnch = "branch" + character(len=*), public, parameter :: seq_infodata_orb_fixed_year = 'fixed_year' + character(len=*), public, parameter :: seq_infodata_orb_variable_year = 'variable_year' + character(len=*), public, parameter :: seq_infodata_orb_fixed_parameters = 'fixed_parameters' + + ! Type to hold pause/resume signaling information + type seq_pause_resume_type + private + character(SHR_KIND_CL) :: atm_resume(num_inst_atm) = ' ' ! atm resume file + character(SHR_KIND_CL) :: lnd_resume(num_inst_lnd) = ' ' ! lnd resume file + character(SHR_KIND_CL) :: ice_resume(num_inst_ice) = ' ' ! ice resume file + character(SHR_KIND_CL) :: ocn_resume(num_inst_ocn) = ' ' ! ocn resume file + character(SHR_KIND_CL) :: glc_resume(num_inst_glc) = ' ' ! glc resume file + character(SHR_KIND_CL) :: rof_resume(num_inst_rof) = ' ' ! rof resume file + character(SHR_KIND_CL) :: wav_resume(num_inst_wav) = ' ' ! wav resume file + character(SHR_KIND_CL) :: cpl_resume = ' ' ! cpl resume file + end type seq_pause_resume_type + + ! InputInfo derived type + + type seq_infodata_type + private ! This type is opaque + + !--- set via namelist and held fixed ---- + character(SHR_KIND_CS) :: cime_model ! acme or cesm + character(SHR_KIND_CL) :: start_type ! Type of startup + character(SHR_KIND_CL) :: case_name ! Short case identification + character(SHR_KIND_CL) :: case_desc ! Long description of this case + character(SHR_KIND_CL) :: model_version ! Model version + character(SHR_KIND_CS) :: username ! Current user + character(SHR_KIND_CS) :: hostname ! Current machine + character(SHR_KIND_CL) :: timing_dir ! Dir for timing files + character(SHR_KIND_CL) :: tchkpt_dir ! Dir for timing checkpoint files + logical :: aqua_planet ! No ice/lnd, analytic ocn, perpetual time + integer(SHR_KIND_IN) :: aqua_planet_sst ! aqua planet analytic sst type + logical :: run_barriers ! barrier component run calls + logical :: brnch_retain_casename ! If branch and can use same casename + logical :: read_restart ! read the restart file, based on start_type + character(SHR_KIND_CL) :: restart_pfile ! Restart pointer file + character(SHR_KIND_CL) :: restart_file ! Full archive path to restart file + logical :: single_column ! single column mode + real (SHR_KIND_R8) :: scmlat ! single column lat + real (SHR_KIND_R8) :: scmlon ! single column lon + character(SHR_KIND_CS) :: logFilePostFix ! postfix for output log files + character(SHR_KIND_CL) :: outPathRoot ! root for output log files + logical :: perpetual ! perpetual flag + integer(SHR_KIND_IN) :: perpetual_ymd ! perpetual date + integer(SHR_KIND_IN) :: orb_iyear ! orbital year + integer(SHR_KIND_IN) :: orb_iyear_align ! model year associated with orb year + character(SHR_KIND_CL) :: orb_mode ! orbital mode + real(SHR_KIND_R8) :: orb_eccen ! See shr_orb_mod + real(SHR_KIND_R8) :: orb_obliq ! See shr_orb_mod + real(SHR_KIND_R8) :: orb_mvelp ! See shr_orb_mod + real(SHR_KIND_R8) :: orb_obliqr ! See shr_orb_mod + real(SHR_KIND_R8) :: orb_lambm0 ! See shr_orb_mod + real(SHR_KIND_R8) :: orb_mvelpp ! See shr_orb_mod + character(SHR_KIND_CS) :: wv_sat_scheme ! Water vapor saturation pressure scheme + real(SHR_KIND_R8) :: wv_sat_transition_start ! Saturation transition range + logical :: wv_sat_use_tables ! Saturation pressure lookup tables + real(SHR_KIND_R8) :: wv_sat_table_spacing! Saturation pressure table resolution + character(SHR_KIND_CS) :: tfreeze_option ! Freezing point calculation + character(SHR_KIND_CL) :: flux_epbal ! selects E,P,R adjustment technique + logical :: flux_albav ! T => no diurnal cycle in ocn albedos + logical :: flux_diurnal ! T => diurnal cycle in atm/ocn fluxes + real(SHR_KIND_R8) :: gust_fac ! wind gustiness factor + character(SHR_KIND_CL) :: glc_renormalize_smb ! Whether to renormalize smb sent from lnd -> glc + real(SHR_KIND_R8) :: wall_time_limit ! force stop time limit (hours) + character(SHR_KIND_CS) :: force_stop_at ! when to force a stop (month, day, etc) + character(SHR_KIND_CL) :: atm_gnam ! atm grid + character(SHR_KIND_CL) :: lnd_gnam ! lnd grid + character(SHR_KIND_CL) :: ocn_gnam ! ocn grid + character(SHR_KIND_CL) :: ice_gnam ! ice grid + character(SHR_KIND_CL) :: rof_gnam ! rof grid + character(SHR_KIND_CL) :: glc_gnam ! glc grid + character(SHR_KIND_CL) :: wav_gnam ! wav grid + logical :: shr_map_dopole ! pole corrections in shr_map_mod + character(SHR_KIND_CL) :: vect_map ! vector mapping option, none, cart3d, cart3d_diag, cart3d_uvw, cart3d_uvw_diag + character(SHR_KIND_CS) :: aoflux_grid ! grid for atm ocn flux calc + integer :: cpl_decomp ! coupler decomp + character(SHR_KIND_CL) :: cpl_seq_option ! coupler sequencing option + + logical :: do_budgets ! do heat/water budgets diagnostics + logical :: do_histinit ! write out initial history file + integer :: budget_inst ! instantaneous budget level + integer :: budget_daily ! daily budget level + integer :: budget_month ! monthly budget level + integer :: budget_ann ! annual budget level + integer :: budget_ltann ! long term budget level written at end of year + integer :: budget_ltend ! long term budget level written at end of run + logical :: drv_threading ! is threading control in driver turned on + logical :: histaux_a2x ! cpl writes aux hist files: a2x every c2a comm + logical :: histaux_a2x1hri ! cpl writes aux hist files: a2x 1hr instaneous values + logical :: histaux_a2x1hr ! cpl writes aux hist files: a2x 1hr + logical :: histaux_a2x3hr ! cpl writes aux hist files: a2x 3hr states + logical :: histaux_a2x3hrp ! cpl writes aux hist files: a2x 3hr precip + logical :: histaux_a2x24hr ! cpl writes aux hist files: a2x daily all + logical :: histaux_l2x1yr ! cpl writes aux hist files: l2x annual all + logical :: histaux_l2x ! cpl writes aux hist files: l2x every c2l comm + logical :: histaux_r2x ! cpl writes aux hist files: r2x every c2o comm + logical :: histavg_atm ! cpl writes atm fields in average history file + logical :: histavg_lnd ! cpl writes lnd fields in average history file + logical :: histavg_ocn ! cpl writes ocn fields in average history file + logical :: histavg_ice ! cpl writes ice fields in average history file + logical :: histavg_rof ! cpl writes rof fields in average history file + logical :: histavg_glc ! cpl writes glc fields in average history file + logical :: histavg_wav ! cpl writes wav fields in average history file + logical :: histavg_xao ! cpl writes flux xao fields in average history file + real(SHR_KIND_R8) :: eps_frac ! fraction error tolerance + real(SHR_KIND_R8) :: eps_amask ! atm mask error tolerance + real(SHR_KIND_R8) :: eps_agrid ! atm grid error tolerance + real(SHR_KIND_R8) :: eps_aarea ! atm area error tolerance + real(SHR_KIND_R8) :: eps_omask ! ocn mask error tolerance + real(SHR_KIND_R8) :: eps_ogrid ! ocn grid error tolerance + real(SHR_KIND_R8) :: eps_oarea ! ocn area error tolerance + logical :: mct_usealltoall ! flag for mct alltoall + logical :: mct_usevector ! flag for mct vector + + logical :: reprosum_use_ddpdd ! use ddpdd algorithm + real(SHR_KIND_R8) :: reprosum_diffmax ! maximum difference tolerance + logical :: reprosum_recompute ! recompute reprosum with nonscalable algorithm + ! if reprosum_diffmax is exceeded + + !--- set via namelist and may be time varying --- + integer(SHR_KIND_IN) :: info_debug ! debug level + logical :: bfbflag ! turn on bfb option + logical :: esmf_map_flag ! do we use esmf mapping + + !--- set via components and held fixed --- + logical :: atm_present ! does component model exist + logical :: atm_prognostic ! does component model need input data from driver + logical :: lnd_present ! does component model exist + logical :: lnd_prognostic ! does component model need input data from driver + logical :: rof_present ! does rof component exist + logical :: rofice_present ! does rof have iceberg coupling on + logical :: rof_prognostic ! does rof component need input data + logical :: flood_present ! does rof have flooding on + logical :: ocn_present ! does component model exist + logical :: ocn_prognostic ! does component model need input data from driver + logical :: ocnrof_prognostic ! does component need rof data + logical :: ice_present ! does component model exist + logical :: ice_prognostic ! does component model need input data from driver + logical :: iceberg_prognostic ! does the ice model support icebergs + logical :: glc_present ! does component model exist + logical :: glclnd_present ! does glc have land coupling fields on + logical :: glcocn_present ! does glc have ocean runoff on + logical :: glcice_present ! does glc have iceberg coupling on + logical :: glc_prognostic ! does component model need input data from driver + logical :: glc_coupled_fluxes ! does glc send fluxes to other components (only relevant if glc_present is .true.) + logical :: wav_present ! does component model exist + logical :: wav_prognostic ! does component model need input data from driver + logical :: esp_present ! does component model exist + logical :: esp_prognostic ! does component model need input data from driver + logical :: dead_comps ! do we have dead models + integer(SHR_KIND_IN) :: atm_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: atm_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: lnd_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: lnd_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: ice_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: ice_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: ocn_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: ocn_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: rof_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: rof_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: glc_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: glc_ny ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: wav_nx ! nx, ny of "2d" grid + integer(SHR_KIND_IN) :: wav_ny ! nx, ny of "2d" grid + + !--- set via components and may be time varying --- + real(SHR_KIND_R8) :: nextsw_cday ! calendar of next atm shortwave + real(SHR_KIND_R8) :: precip_fact ! precip factor + integer(SHR_KIND_IN) :: atm_phase ! atm phase + integer(SHR_KIND_IN) :: lnd_phase ! lnd phase + integer(SHR_KIND_IN) :: ice_phase ! ice phase + integer(SHR_KIND_IN) :: ocn_phase ! ocn phase + integer(SHR_KIND_IN) :: glc_phase ! glc phase + integer(SHR_KIND_IN) :: rof_phase ! rof phase + integer(SHR_KIND_IN) :: wav_phase ! wav phase + integer(SHR_KIND_IN) :: esp_phase ! esp phase + logical :: atm_aero ! atmosphere aerosols + logical :: glc_g2lupdate ! update glc2lnd fields in lnd model + type(seq_pause_resume_type), pointer :: pause_resume => NULL() + real(shr_kind_r8) :: max_cplstep_time ! abort if cplstep time exceeds this value + !--- set from restart file --- + character(SHR_KIND_CL) :: rest_case_name ! Short case identification + !--- set by driver and may be time varying + logical :: glc_valid_input ! is valid accumulated data being sent to prognostic glc + end type seq_infodata_type + + ! --- public interfaces -------------------------------------------------------- + interface seq_infodata_GetData + module procedure seq_infodata_GetData_explicit +#ifndef CPRPGI + module procedure seq_infodata_GetData_bytype +#endif +! ^ ifndef CPRPGI + end interface + + interface seq_infodata_PutData + module procedure seq_infodata_PutData_explicit +#ifndef CPRPGI + module procedure seq_infodata_PutData_bytype +#endif +! ^ ifndef CPRPGI + end interface + + ! --- Private local data ------------------------------------------------------- + + character(len=*),parameter :: sp_str = 'str_undefined' + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_Init -- read in CIME shared namelist +! +! !DESCRIPTION: +! +! Read in input from seq_infodata_inparm namelist, output cime derived type for +! miscillaneous info. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_Init( infodata, nmlfile, ID, pioid, cpl_tag) + +! !USES: + + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use shr_string_mod, only : shr_string_toUpper, shr_string_listAppend + use shr_mpi_mod, only : shr_mpi_bcast + use seq_timemgr_mod, only : seq_timemgr_pause_active + use seq_io_read_mod, only : seq_io_read + use pio, only : file_desc_t + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! infodata object + character(len=*), intent(IN) :: nmlfile ! Name-list filename + integer(SHR_KIND_IN), intent(IN) :: ID ! seq_comm ID + type(file_desc_T) :: pioid + character(len=*), optional, intent(IN) :: cpl_tag ! cpl instance suffix +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_Init) ' + integer(SHR_KIND_IN),parameter :: aqua_perpetual_ymd = 321 + + integer :: mpicom ! MPI communicator + integer :: ierr ! I/O error code + integer :: unitn ! Namelist unit number to read + + !------ namelist ----- + character(SHR_KIND_CS) :: cime_model ! acme or cesm + character(SHR_KIND_CL) :: case_desc ! Case long description + character(SHR_KIND_CL) :: case_name ! Case short name + character(SHR_KIND_CL) :: model_version ! Model version + character(SHR_KIND_CS) :: username ! Current user + character(SHR_KIND_CS) :: hostname ! Current machine + character(SHR_KIND_CL) :: start_type ! Startup-type: startup, continue, branch + character(SHR_KIND_CL) :: timing_dir ! Dir for timing files + character(SHR_KIND_CL) :: tchkpt_dir ! Dir for timing checkpoint files + logical :: aqua_planet ! Aqua-planet mode (surface is all ocean) + integer(SHR_KIND_IN) :: aqua_planet_sst ! analytic sst field + logical :: run_barriers ! barrier component run calls + logical :: brnch_retain_casename ! If retain casename for branch + integer(SHR_KIND_IN) :: info_debug ! debug flag + logical :: bfbflag ! bit for bit flag + logical :: esmf_map_flag ! esmf mapping flag + character(SHR_KIND_CL) :: restart_pfile ! Restart pointer filename + character(SHR_KIND_CL) :: restart_file ! Restart filename + + logical :: single_column ! single column mode + real (SHR_KIND_R8) :: scmlat ! single column mode latitude + real (SHR_KIND_R8) :: scmlon ! single column mode longitude + character(SHR_KIND_CS) :: logFilePostFix ! postfix for output log files + character(SHR_KIND_CL) :: outPathRoot ! root output files + logical :: perpetual ! perpetual mode + integer(SHR_KIND_IN) :: perpetual_ymd ! perpetual ymd + integer(SHR_KIND_IN) :: orb_iyear ! orbital year + integer(SHR_KIND_IN) :: orb_iyear_align ! model year associated with orb year + character(SHR_KIND_CL) :: orb_mode ! orbital mode + real(SHR_KIND_R8) :: orb_obliq ! Obliquity of orbit + real(SHR_KIND_R8) :: orb_eccen ! Eccentricity of orbit + real(SHR_KIND_R8) :: orb_mvelp ! Location of vernal equinox + real(SHR_KIND_R8) :: orb_obliqr ! Obliquity in radians + real(SHR_KIND_R8) :: orb_lambm0 ! lon of per at vernal equ + real(SHR_KIND_R8) :: orb_mvelpp ! mvelp plus pi + character(SHR_KIND_CS) :: wv_sat_scheme ! Water vapor saturation pressure scheme + real(SHR_KIND_R8) :: wv_sat_transition_start! Saturation transition range + logical :: wv_sat_use_tables ! Saturation pressure lookup tables + real(SHR_KIND_R8) :: wv_sat_table_spacing ! Saturation pressure table resolution + character(SHR_KIND_CS) :: tfreeze_option ! Freezing point calculation + character(SHR_KIND_CL) :: flux_epbal ! selects E,P,R adjustment technique + logical :: flux_albav ! T => no diurnal cycle in ocn albedos + logical :: flux_diurnal ! T => diurnal cycle in atm/ocn fluxes + real(SHR_KIND_R8) :: gust_fac ! wind gustiness factor + character(SHR_KIND_CL) :: glc_renormalize_smb ! Whether to renormalize smb sent from lnd -> glc + real(SHR_KIND_R8) :: wall_time_limit ! force stop time limit (hours) + character(SHR_KIND_CS) :: force_stop_at ! when to force a stop (month, day, etc) + character(SHR_KIND_CL) :: atm_gnam ! atm grid + character(SHR_KIND_CL) :: lnd_gnam ! lnd grid + character(SHR_KIND_CL) :: ocn_gnam ! ocn grid + character(SHR_KIND_CL) :: ice_gnam ! ice grid + character(SHR_KIND_CL) :: rof_gnam ! rof grid + character(SHR_KIND_CL) :: glc_gnam ! glc grid + character(SHR_KIND_CL) :: wav_gnam ! wav grid + logical :: shr_map_dopole ! pole corrections in shr_map_mod + character(SHR_KIND_CL) :: vect_map ! vector mapping option + character(SHR_KIND_CS) :: aoflux_grid ! grid for atm ocn flux calc + integer :: cpl_decomp ! coupler decomp + character(SHR_KIND_CL) :: cpl_seq_option ! coupler sequencing option + + logical :: do_budgets ! do heat/water budgets diagnostics + logical :: do_histinit ! write out initial history file + integer :: budget_inst ! instantaneous budget level + integer :: budget_daily ! daily budget level + integer :: budget_month ! monthly budget level + integer :: budget_ann ! annual budget level + integer :: budget_ltann ! long term budget level written at end of year + integer :: budget_ltend ! long term budget level written at end of run + logical :: histaux_a2x ! cpl writes aux hist files: a2x every c2a comm + logical :: histaux_a2x1hri ! cpl writes aux hist files: a2x 1hr instaneous values + logical :: histaux_a2x1hr ! cpl writes aux hist files: a2x 1hr + logical :: histaux_a2x3hr ! cpl writes aux hist files: a2x 3hr states + logical :: histaux_a2x3hrp ! cpl writes aux hist files: a2x 2hr precip + logical :: histaux_a2x24hr ! cpl writes aux hist files: a2x daily all + logical :: histaux_l2x1yr ! cpl writes aux hist files: l2x annual all + logical :: histaux_l2x ! cpl writes aux hist files: l2x every c2l comm + logical :: histaux_r2x ! cpl writes aux hist files: r2x every c2o comm + logical :: histavg_atm ! cpl writes atm fields in average history file + logical :: histavg_lnd ! cpl writes lnd fields in average history file + logical :: histavg_ocn ! cpl writes ocn fields in average history file + logical :: histavg_ice ! cpl writes ice fields in average history file + logical :: histavg_rof ! cpl writes rof fields in average history file + logical :: histavg_glc ! cpl writes glc fields in average history file + logical :: histavg_wav ! cpl writes wav fields in average history file + logical :: histavg_xao ! cpl writes flux xao fields in average history file + logical :: drv_threading ! is threading control in driver turned on + real(SHR_KIND_R8) :: eps_frac ! fraction error tolerance + real(SHR_KIND_R8) :: eps_amask ! atm mask error tolerance + real(SHR_KIND_R8) :: eps_agrid ! atm grid error tolerance + real(SHR_KIND_R8) :: eps_aarea ! atm area error tolerance + real(SHR_KIND_R8) :: eps_omask ! ocn mask error tolerance + real(SHR_KIND_R8) :: eps_ogrid ! ocn grid error tolerance + real(SHR_KIND_R8) :: eps_oarea ! ocn area error tolerance + logical :: reprosum_use_ddpdd ! use ddpdd algorithm + real(SHR_KIND_R8) :: reprosum_diffmax ! maximum difference tolerance + logical :: reprosum_recompute ! recompute reprosum with nonscalable algorithm + ! if reprosum_diffmax is exceeded + logical :: mct_usealltoall ! flag for mct alltoall + logical :: mct_usevector ! flag for mct vector + real(shr_kind_r8) :: max_cplstep_time ! abort if cplstep time exceeds this value + + namelist /seq_infodata_inparm/ & + cime_model, case_desc, case_name, start_type, tchkpt_dir, & + model_version, username, hostname, timing_dir, & + aqua_planet,aqua_planet_sst, & + brnch_retain_casename, info_debug, bfbflag, & + restart_pfile, restart_file, run_barriers, & + single_column, scmlat, force_stop_at, & + scmlon, logFilePostFix, outPathRoot, flux_diurnal, gust_fac,& + perpetual, perpetual_ymd, flux_epbal, flux_albav, & + orb_iyear_align, orb_mode, wall_time_limit, & + orb_iyear, orb_obliq, orb_eccen, orb_mvelp, & + wv_sat_scheme, wv_sat_transition_start, & + wv_sat_use_tables, wv_sat_table_spacing, & + tfreeze_option, glc_renormalize_smb, & + ice_gnam, rof_gnam, glc_gnam, wav_gnam, & + atm_gnam, lnd_gnam, ocn_gnam, cpl_decomp, & + shr_map_dopole, vect_map, aoflux_grid, do_histinit, & + do_budgets, drv_threading, & + budget_inst, budget_daily, budget_month, & + budget_ann, budget_ltann, budget_ltend, & + histaux_a2x,histaux_a2x1hri,histaux_a2x1hr, & + histaux_a2x3hr,histaux_a2x3hrp, & + histaux_a2x24hr,histaux_l2x ,histaux_r2x, & + histavg_atm, histavg_lnd, histavg_ocn, histavg_ice, & + histavg_rof, histavg_glc, histavg_wav, histavg_xao, & + histaux_l2x1yr, cpl_seq_option, & + eps_frac, eps_amask, & + eps_agrid, eps_aarea, eps_omask, eps_ogrid, & + eps_oarea, esmf_map_flag, & + reprosum_use_ddpdd, reprosum_diffmax, reprosum_recompute, & + mct_usealltoall, mct_usevector, max_cplstep_time + +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(ID,mpicom=mpicom) + + !--------------------------------------------------------------------------- + ! Set infodata on root pe + !--------------------------------------------------------------------------- + if (seq_comm_iamroot(ID)) then + + !--------------------------------------------------------------------------- + ! Set namelist defaults + !--------------------------------------------------------------------------- + cime_model = 'unknown' + case_desc = ' ' + case_name = ' ' + model_version = 'unknown' + username = 'unknown' + hostname = 'unknown' + timing_dir = '.' + tchkpt_dir = '.' + start_type = ' ' + aqua_planet = .false. + aqua_planet_sst = 1 + run_barriers = .false. + brnch_retain_casename = .false. + info_debug = 1 + bfbflag = .false. + esmf_map_flag = .false. + restart_pfile = 'rpointer.drv' + restart_file = trim(sp_str) + single_column = .false. + scmlat = -999. + scmlon = -999. + logFilePostFix = '.log' + outPathRoot = './' + perpetual = .false. + perpetual_ymd = -999 + orb_mode = seq_infodata_orb_fixed_year + orb_iyear = SHR_ORB_UNDEF_INT + orb_iyear_align = SHR_ORB_UNDEF_INT + orb_obliq = SHR_ORB_UNDEF_REAL + orb_eccen = SHR_ORB_UNDEF_REAL + orb_mvelp = SHR_ORB_UNDEF_REAL + wv_sat_scheme = "GoffGratch" + wv_sat_transition_start = 20.0 + wv_sat_use_tables = .false. + wv_sat_table_spacing = 1.0 + tfreeze_option = 'minus1p8' + flux_epbal = 'off' + flux_albav = .false. + flux_diurnal = .false. + gust_fac = huge(1.0_SHR_KIND_R8) + glc_renormalize_smb = 'on_if_glc_coupled_fluxes' + wall_time_limit = -1.0 + force_stop_at = 'month' + atm_gnam = 'undefined' + lnd_gnam = 'undefined' + ocn_gnam = 'undefined' + ice_gnam = 'undefined' + rof_gnam = 'undefined' + glc_gnam = 'undefined' + wav_gnam = 'undefined' + shr_map_dopole = .true. + vect_map = 'cart3d' + aoflux_grid = 'ocn' + cpl_decomp = 0 + cpl_seq_option = 'CESM1_MOD' + do_budgets = .false. + do_histinit = .false. + budget_inst = 0 + budget_daily = 0 + budget_month = 1 + budget_ann = 1 + budget_ltann = 1 + budget_ltend = 0 + histaux_a2x = .false. + histaux_a2x1hri = .false. + histaux_a2x1hr = .false. + histaux_a2x3hr = .false. + histaux_a2x3hrp = .false. + histaux_a2x24hr = .false. + histaux_l2x1yr = .false. + histaux_l2x = .false. + histaux_r2x = .false. + histavg_atm = .true. + histavg_lnd = .true. + histavg_ocn = .true. + histavg_ice = .true. + histavg_rof = .true. + histavg_glc = .true. + histavg_wav = .true. + histavg_xao = .true. + drv_threading = .false. + eps_frac = 1.0e-02_SHR_KIND_R8 + eps_amask = 1.0e-13_SHR_KIND_R8 + eps_agrid = 1.0e-12_SHR_KIND_R8 + eps_aarea = 9.0e-07_SHR_KIND_R8 + eps_omask = 1.0e-06_SHR_KIND_R8 + eps_ogrid = 1.0e-02_SHR_KIND_R8 + eps_oarea = 1.0e-01_SHR_KIND_R8 + reprosum_use_ddpdd = .false. + reprosum_diffmax = -1.0e-8 + reprosum_recompute = .false. + mct_usealltoall = .false. + mct_usevector = .false. + max_cplstep_time = 0.0 + + !--------------------------------------------------------------------------- + ! Read in namelist + !--------------------------------------------------------------------------- + unitn = shr_file_getUnit() + write(logunit,"(A)") subname,' read seq_infodata_inparm namelist from: '//trim(nmlfile) + open( unitn, file=trim(nmlfile), status='old' ) + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=seq_infodata_inparm,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' end of file or end of record condition' ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + + !--------------------------------------------------------------------------- + ! Set infodata on root pe + !--------------------------------------------------------------------------- + infodata%cime_model = cime_model + infodata%case_desc = case_desc + infodata%case_name = case_name + infodata%model_version = model_version + infodata%username = username + infodata%hostname = hostname + infodata%start_type = start_type + infodata%timing_dir = timing_dir + infodata%tchkpt_dir = tchkpt_dir + infodata%aqua_planet = aqua_planet + infodata%aqua_planet_sst = aqua_planet_sst + infodata%run_barriers = run_barriers + infodata%brnch_retain_casename = brnch_retain_casename + infodata%restart_pfile = restart_pfile + infodata%restart_file = restart_file + if (present(cpl_tag)) then + if (len(cpl_tag) > 0) then + if (trim(restart_file) /= trim(sp_str)) then + write(logunit,*) trim(subname),' ERROR: restart_file can '//& + 'only be read from restart pointer files when using multiple couplers ' + call shr_sys_abort(subname//' ERROR: invalid settings for restart_file ') + end if + end if + infodata%restart_file = restart_file + infodata%restart_pfile = trim(restart_pfile) // trim(cpl_tag) + else + infodata%restart_pfile = restart_pfile + infodata%restart_file = restart_file + end if + infodata%single_column = single_column + infodata%scmlat = scmlat + infodata%scmlon = scmlon + infodata%logFilePostFix = logFilePostFix + infodata%outPathRoot = outPathRoot + infodata%perpetual = perpetual + infodata%perpetual_ymd = perpetual_ymd + infodata%wv_sat_scheme = wv_sat_scheme + infodata%wv_sat_transition_start = wv_sat_transition_start + infodata%wv_sat_use_tables = wv_sat_use_tables + infodata%wv_sat_table_spacing = wv_sat_table_spacing + infodata%tfreeze_option = tfreeze_option + infodata%flux_epbal = flux_epbal + infodata%flux_albav = flux_albav + infodata%flux_diurnal = flux_diurnal + infodata%gust_fac = gust_fac + infodata%glc_renormalize_smb = glc_renormalize_smb + infodata%wall_time_limit = wall_time_limit + infodata%force_stop_at = force_stop_at + infodata%atm_gnam = atm_gnam + infodata%lnd_gnam = lnd_gnam + infodata%ocn_gnam = ocn_gnam + infodata%ice_gnam = ice_gnam + infodata%rof_gnam = rof_gnam + infodata%glc_gnam = glc_gnam + infodata%wav_gnam = wav_gnam + infodata%shr_map_dopole = shr_map_dopole + infodata%vect_map = vect_map + infodata%aoflux_grid = aoflux_grid + infodata%cpl_decomp = cpl_decomp + infodata%cpl_seq_option = cpl_seq_option + infodata%do_budgets = do_budgets + infodata%do_histinit = do_histinit + infodata%budget_inst = budget_inst + infodata%budget_daily = budget_daily + infodata%budget_month = budget_month + infodata%budget_ann = budget_ann + infodata%budget_ltann = budget_ltann + infodata%budget_ltend = budget_ltend + infodata%histaux_a2x = histaux_a2x + infodata%histaux_a2x1hri = histaux_a2x1hri + infodata%histaux_a2x1hr = histaux_a2x1hr + infodata%histaux_a2x3hr = histaux_a2x3hr + infodata%histaux_a2x3hrp = histaux_a2x3hrp + infodata%histaux_a2x24hr = histaux_a2x24hr + infodata%histaux_l2x1yr = histaux_l2x1yr + infodata%histaux_l2x = histaux_l2x + infodata%histaux_r2x = histaux_r2x + infodata%histavg_atm = histavg_atm + infodata%histavg_lnd = histavg_lnd + infodata%histavg_ocn = histavg_ocn + infodata%histavg_ice = histavg_ice + infodata%histavg_rof = histavg_rof + infodata%histavg_glc = histavg_glc + infodata%histavg_wav = histavg_wav + infodata%histavg_xao = histavg_xao + infodata%drv_threading = drv_threading + infodata%eps_frac = eps_frac + infodata%eps_amask = eps_amask + infodata%eps_agrid = eps_agrid + infodata%eps_aarea = eps_aarea + infodata%eps_omask = eps_omask + infodata%eps_ogrid = eps_ogrid + infodata%eps_oarea = eps_oarea + infodata%reprosum_use_ddpdd = reprosum_use_ddpdd + infodata%reprosum_diffmax = reprosum_diffmax + infodata%reprosum_recompute = reprosum_recompute + infodata%mct_usealltoall = mct_usealltoall + infodata%mct_usevector = mct_usevector + + infodata%info_debug = info_debug + infodata%bfbflag = bfbflag + infodata%esmf_map_flag = esmf_map_flag + + infodata%atm_present = .true. + infodata%lnd_present = .true. + infodata%rof_present = .true. + infodata%rofice_present = .true. + infodata%flood_present = .true. + infodata%ocn_present = .true. + infodata%ice_present = .true. + infodata%glc_present = .true. + infodata%wav_present = .true. + infodata%glclnd_present = .true. + infodata%glcocn_present = .true. + infodata%glcice_present = .true. + infodata%esp_present = .true. + + infodata%atm_prognostic = .false. + infodata%lnd_prognostic = .false. + infodata%rof_prognostic = .false. + infodata%ocn_prognostic = .false. + infodata%ocnrof_prognostic = .false. + infodata%ice_prognostic = .false. + infodata%glc_prognostic = .false. + ! It's safest to assume glc_coupled_fluxes = .true. if it's not set elsewhere, + ! because this is needed for conservation in some cases. Note that it is ignored + ! if glc_present is .false., so it's okay to just start out assuming it's .true. + ! in all cases. + infodata%glc_coupled_fluxes = .true. + infodata%wav_prognostic = .false. + infodata%iceberg_prognostic = .false. + infodata%esp_prognostic = .false. + infodata%dead_comps = .false. + + infodata%atm_nx = 0 + infodata%atm_ny = 0 + infodata%lnd_nx = 0 + infodata%lnd_ny = 0 + infodata%rof_nx = 0 + infodata%rof_ny = 0 + infodata%ice_nx = 0 + infodata%ice_ny = 0 + infodata%ocn_nx = 0 + infodata%ocn_ny = 0 + infodata%glc_nx = 0 + infodata%glc_ny = 0 + infodata%wav_nx = 0 + infodata%wav_ny = 0 + + infodata%nextsw_cday = -1.0_SHR_KIND_R8 + infodata%precip_fact = 1.0_SHR_KIND_R8 + infodata%atm_phase = 1 + infodata%lnd_phase = 1 + infodata%ocn_phase = 1 + infodata%ice_phase = 1 + infodata%glc_phase = 1 + infodata%rof_phase = 1 + infodata%wav_phase = 1 + infodata%atm_aero = .false. + infodata%glc_g2lupdate = .false. + infodata%glc_valid_input = .true. + if (associated(infodata%pause_resume)) then + deallocate(infodata%pause_resume) + end if + nullify(infodata%pause_resume) + + infodata%max_cplstep_time = max_cplstep_time + !--------------------------------------------------------------- + ! check orbital mode, reset unused parameters, validate settings + !--------------------------------------------------------------- + if (trim(orb_mode) == trim(seq_infodata_orb_fixed_year)) then + orb_obliq = SHR_ORB_UNDEF_REAL + orb_eccen = SHR_ORB_UNDEF_REAL + orb_mvelp = SHR_ORB_UNDEF_REAL + if (orb_iyear == SHR_ORB_UNDEF_INT) then + write(logunit,*) trim(subname),' ERROR: invalid settings orb_mode =',trim(orb_mode) + write(logunit,*) trim(subname),' ERROR: fixed_year settings = ',orb_iyear + call shr_sys_abort(subname//' ERROR: invalid settings for orb_mode '//trim(orb_mode)) + endif + elseif (trim(orb_mode) == trim(seq_infodata_orb_variable_year)) then + orb_obliq = SHR_ORB_UNDEF_REAL + orb_eccen = SHR_ORB_UNDEF_REAL + orb_mvelp = SHR_ORB_UNDEF_REAL + if (orb_iyear == SHR_ORB_UNDEF_INT .or. & + orb_iyear_align == SHR_ORB_UNDEF_INT) then + write(logunit,*) trim(subname),' ERROR: invalid settings orb_mode =',trim(orb_mode) + write(logunit,*) trim(subname),' ERROR: variable_year settings = ',orb_iyear,orb_iyear_align + call shr_sys_abort(subname//' ERROR: invalid settings for orb_mode '//trim(orb_mode)) + endif + elseif (trim(orb_mode) == trim(seq_infodata_orb_fixed_parameters)) then + !-- force orb_iyear to undef to make sure shr_orb_params works properly + orb_iyear = SHR_ORB_UNDEF_INT + orb_iyear_align = SHR_ORB_UNDEF_INT + if (orb_eccen == SHR_ORB_UNDEF_REAL .or. & + orb_obliq == SHR_ORB_UNDEF_REAL .or. & + orb_mvelp == SHR_ORB_UNDEF_REAL) then + write(logunit,*) trim(subname),' ERROR: invalid settings orb_mode =',trim(orb_mode) + write(logunit,*) trim(subname),' ERROR: orb_eccen = ',orb_eccen + write(logunit,*) trim(subname),' ERROR: orb_obliq = ',orb_obliq + write(logunit,*) trim(subname),' ERROR: orb_mvelp = ',orb_mvelp + call shr_sys_abort(subname//' ERROR: invalid settings for orb_mode '//trim(orb_mode)) + endif + else + call shr_sys_abort(subname//' ERROR: invalid orb_mode '//trim(orb_mode)) + endif + + call shr_orb_params(orb_iyear, orb_eccen, orb_obliq, orb_mvelp, & + orb_obliqr, orb_lambm0, orb_mvelpp, .true.) + + infodata%orb_mode = orb_mode + infodata%orb_iyear = orb_iyear + infodata%orb_iyear_align = orb_iyear_align + infodata%orb_eccen = orb_eccen + infodata%orb_obliq = orb_obliq + infodata%orb_mvelp = orb_mvelp + infodata%orb_obliqr = orb_obliqr + infodata%orb_lambm0 = orb_lambm0 + infodata%orb_mvelpp = orb_mvelpp + + !--- Derive a few things --- + infodata%rest_case_name = ' ' + infodata%read_restart = .false. + if (trim(start_type) == trim(seq_infodata_start_type_cont) .or. & + trim(start_type) == trim(seq_infodata_start_type_brnch)) then + infodata%read_restart = .true. + endif + + end if + + !----------------------------------------------------- + ! Read Restart (seq_io_read must be called on all pes) + !----------------------------------------------------- + call shr_mpi_bcast(infodata%read_restart,mpicom) + if (infodata%read_restart) then + !--- read rpointer if restart_file is set to sp_str --- + if (seq_comm_iamroot(ID)) then + if (trim(infodata%restart_file) == trim(sp_str)) then + unitn = shr_file_getUnit() + if (loglevel > 0) write(logunit,"(3A)") subname," read rpointer file ", & + trim(infodata%restart_pfile) + open(unitn, file=infodata%restart_pfile, form='FORMATTED', status='old',iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: rpointer file open returns an'// & + ' error condition' ) + end if + read(unitn,'(a)', iostat=ierr) infodata%restart_file + if (ierr < 0) then + call shr_sys_abort( subname//':: rpointer file read returns an'// & + ' error condition' ) + end if + close(unitn) + call shr_file_freeUnit( unitn ) + write(logunit,"(3A)") subname,' restart file from rpointer= ', & + trim(infodata%restart_file) + endif + endif + call shr_mpi_bcast(infodata%restart_file,mpicom) + !--- NOTE: use CPLID here because seq_io is only value on CPLID + if (seq_comm_iamin(CPLID)) then + call seq_io_read(infodata%restart_file,pioid,infodata%nextsw_cday ,'seq_infodata_nextsw_cday') + call seq_io_read(infodata%restart_file,pioid,infodata%precip_fact ,'seq_infodata_precip_fact') + call seq_io_read(infodata%restart_file,pioid,infodata%rest_case_name,'seq_infodata_case_name') + endif + !--- Send from CPLID ROOT to GLOBALID ROOT, use bcast as surrogate + call shr_mpi_bcast(infodata%nextsw_cday,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast(infodata%precip_fact,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast(infodata%rest_case_name,mpicom,pebcast=seq_comm_gloroot(CPLID)) + endif + + if (seq_comm_iamroot(ID)) then + if (infodata%aqua_planet) then + infodata%atm_present = .true. + infodata%lnd_present = .false. + infodata%rof_present = .false. + infodata%rofice_present = .false. + infodata%flood_present = .false. + infodata%ice_present = .false. + infodata%ocn_present = .true. + infodata%glc_present = .false. + infodata%wav_present = .false. + infodata%glclnd_present = .false. + infodata%glcocn_present = .false. + infodata%glcice_present = .false. + infodata%esp_present = .false. + end if + + if ( infodata%aqua_planet ) then + infodata%aqua_planet_sst = 1 + infodata%perpetual = .true. + infodata%perpetual_ymd = aqua_perpetual_ymd + endif + + ! --- Error check the input values ------ + call seq_infodata_Check( infodata ) + + end if + + call seq_infodata_bcast(infodata,mpicom) + +END SUBROUTINE seq_infodata_Init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_Init2 -- initialize infodata structures +! +! !DESCRIPTION: +! +! Initialize infodata items that depend on the time manager setup +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_Init2(infodata, ID) + +! !USES: + + use seq_timemgr_mod, only : seq_timemgr_pause_active + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! infodata object + integer(SHR_KIND_IN), intent(IN) :: ID ! seq_comm ID +!EOP + + !----- local ----- + integer :: mpicom ! MPI communicator + + call seq_comm_setptrs(ID, mpicom=mpicom) + !---------------------------------------------------------- + !| If pause/resume is active, initialize the resume data + !---------------------------------------------------------- + if (seq_timemgr_pause_active() .and. (.not. associated(infodata%pause_resume))) then + allocate(infodata%pause_resume) + end if + call seq_infodata_bcast(infodata, mpicom) + +END SUBROUTINE seq_infodata_Init2 + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_infodata_GetData_explicit -- Get values from infodata object +! +! !DESCRIPTION: +! +! Get values out of the infodata object. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_GetData_explicit( infodata, cime_model, case_name, case_desc, timing_dir, & + model_version, username, hostname, rest_case_name, tchkpt_dir, & + start_type, restart_pfile, restart_file, perpetual, perpetual_ymd, & + aqua_planet,aqua_planet_sst, brnch_retain_casename, & + single_column, scmlat,scmlon,logFilePostFix, outPathRoot, & + atm_present, atm_prognostic, lnd_present, lnd_prognostic, rof_prognostic, & + rof_present, ocn_present, ocn_prognostic, ocnrof_prognostic, & + ice_present, ice_prognostic, glc_present, glc_prognostic, & + glc_coupled_fluxes, & + flood_present, wav_present, wav_prognostic, rofice_present, & + glclnd_present, glcocn_present, glcice_present, iceberg_prognostic,& + esp_present, esp_prognostic, & + bfbflag, lnd_gnam, cpl_decomp, cpl_seq_option, & + ice_gnam, rof_gnam, glc_gnam, wav_gnam, & + atm_gnam, ocn_gnam, info_debug, dead_comps, read_restart, & + shr_map_dopole, vect_map, aoflux_grid, flux_epbalfact, & + nextsw_cday, precip_fact, flux_epbal, flux_albav, & + glc_g2lupdate, atm_aero, run_barriers, esmf_map_flag, & + do_budgets, do_histinit, drv_threading, flux_diurnal, gust_fac, & + budget_inst, budget_daily, budget_month, wall_time_limit, & + budget_ann, budget_ltann, budget_ltend , force_stop_at, & + histaux_a2x , histaux_a2x1hri, histaux_a2x1hr, & + histaux_a2x3hr, histaux_a2x3hrp , histaux_l2x1yr, & + histaux_a2x24hr, histaux_l2x , histaux_r2x , orb_obliq, & + histavg_atm, histavg_lnd, histavg_ocn, histavg_ice, & + histavg_rof, histavg_glc, histavg_wav, histavg_xao, & + orb_iyear, orb_iyear_align, orb_mode, orb_mvelp, & + orb_eccen, orb_obliqr, orb_lambm0, orb_mvelpp, wv_sat_scheme, & + wv_sat_transition_start, wv_sat_use_tables, wv_sat_table_spacing, & + tfreeze_option, glc_renormalize_smb, & + glc_phase, rof_phase, atm_phase, lnd_phase, ocn_phase, ice_phase, & + wav_phase, esp_phase, wav_nx, wav_ny, atm_nx, atm_ny, & + lnd_nx, lnd_ny, rof_nx, rof_ny, ice_nx, ice_ny, ocn_nx, ocn_ny, & + glc_nx, glc_ny, eps_frac, eps_amask, & + eps_agrid, eps_aarea, eps_omask, eps_ogrid, eps_oarea, & + reprosum_use_ddpdd, reprosum_diffmax, reprosum_recompute, & + atm_resume, lnd_resume, ocn_resume, ice_resume, & + glc_resume, rof_resume, wav_resume, cpl_resume, & + mct_usealltoall, mct_usevector, max_cplstep_time, glc_valid_input) + + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(IN) :: infodata ! Input CCSM structure + character(len=*), optional, intent(OUT) :: cime_model ! CIME model (acme or cesm) + character(len=*), optional, intent(OUT) :: start_type ! Start type + character(len=*), optional, intent(OUT) :: case_name ! Short case identification + character(len=*), optional, intent(OUT) :: case_desc ! Long case description + character(len=*), optional, intent(OUT) :: model_version ! Model version + character(len=*), optional, intent(OUT) :: username ! Username + character(len=*), optional, intent(OUT) :: hostname ! Hostname + character(len=*), optional, intent(OUT) :: rest_case_name ! restart casename + character(len=*), optional, intent(OUT) :: timing_dir ! timing dir name + character(len=*), optional, intent(OUT) :: tchkpt_dir ! timing checkpoint dir name + logical, optional, intent(OUT) :: aqua_planet ! aqua_planet mode + integer(SHR_KIND_IN), optional, intent(OUT) :: aqua_planet_sst ! aqua_planet sst_type + logical, optional, intent(OUT) :: run_barriers ! barrier component run calls + logical, optional, intent(OUT) :: brnch_retain_casename + logical, optional, intent(OUT) :: read_restart ! read restart flag + character(len=*), optional, intent(OUT) :: restart_pfile ! Restart pointer file + character(len=*), optional, intent(OUT) :: restart_file ! Restart file pathname + logical, optional, intent(OUT) :: single_column + real (SHR_KIND_R8), optional, intent(OUT) :: scmlat + real (SHR_KIND_R8), optional, intent(OUT) :: scmlon + character(len=*), optional, intent(OUT) :: logFilePostFix ! output log file postfix + character(len=*), optional, intent(OUT) :: outPathRoot ! output file root + logical, optional, intent(OUT) :: perpetual ! If this is perpetual + integer, optional, intent(OUT) :: perpetual_ymd ! If perpetual, date + character(len=*), optional, intent(OUT) :: orb_mode ! orbital mode + integer, optional, intent(OUT) :: orb_iyear ! orbital year + integer, optional, intent(OUT) :: orb_iyear_align ! orbital year model year align + real(SHR_KIND_R8), optional, intent(OUT) :: orb_eccen ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(OUT) :: orb_obliqr ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(OUT) :: orb_obliq ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(OUT) :: orb_lambm0 ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(OUT) :: orb_mvelpp ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(OUT) :: orb_mvelp ! See shr_orb_mod + character(len=*), optional, intent(OUT) :: wv_sat_scheme ! Water vapor saturation pressure scheme + real(SHR_KIND_R8), optional, intent(OUT) :: wv_sat_transition_start ! Saturation transition range + logical, optional, intent(OUT) :: wv_sat_use_tables ! Saturation pressure lookup tables + real(SHR_KIND_R8), optional, intent(OUT) :: wv_sat_table_spacing ! Saturation pressure table resolution + character(len=*), optional, intent(OUT) :: tfreeze_option ! Freezing point of salt water + character(len=*), optional, intent(OUT) :: flux_epbal ! selects E,P,R adjustment technique + logical, optional, intent(OUT) :: flux_albav ! T => no diurnal cycle in ocn albedos + logical, optional, intent(OUT) :: flux_diurnal ! T => diurnal cycle in atm/ocn flux + real(SHR_KIND_R8), optional, intent(OUT) :: gust_fac ! wind gustiness factor + character(len=*), optional, intent(OUT) :: glc_renormalize_smb ! Whether to renormalize smb sent from lnd -> glc + real(SHR_KIND_R8), optional, intent(OUT) :: wall_time_limit ! force stop wall time (hours) + character(len=*), optional, intent(OUT) :: force_stop_at ! force stop at next (month, day, etc) + character(len=*), optional, intent(OUT) :: atm_gnam ! atm grid + character(len=*), optional, intent(OUT) :: lnd_gnam ! lnd grid + character(len=*), optional, intent(OUT) :: ocn_gnam ! ocn grid + character(len=*), optional, intent(OUT) :: ice_gnam ! ice grid + character(len=*), optional, intent(OUT) :: rof_gnam ! rof grid + character(len=*), optional, intent(OUT) :: glc_gnam ! glc grid + character(len=*), optional, intent(OUT) :: wav_gnam ! wav grid + logical, optional, intent(OUT) :: shr_map_dopole ! pole corrections in shr_map_mod + character(len=*), optional, intent(OUT) :: vect_map ! vector mapping option + character(len=*), optional, intent(OUT) :: aoflux_grid ! grid for atm ocn flux calc + integer, optional, intent(OUT) :: cpl_decomp ! coupler decomp + character(len=*), optional, intent(OUT) :: cpl_seq_option ! coupler sequencing option + logical, optional, intent(OUT) :: do_budgets ! heat/water budgets + logical, optional, intent(OUT) :: do_histinit ! initial history file + integer, optional, intent(OUT) :: budget_inst ! inst budget + integer, optional, intent(OUT) :: budget_daily ! daily budget + integer, optional, intent(OUT) :: budget_month ! month budget + integer, optional, intent(OUT) :: budget_ann ! ann budget + integer, optional, intent(OUT) :: budget_ltann ! ltann budget + integer, optional, intent(OUT) :: budget_ltend ! ltend budget + logical, optional, intent(OUT) :: histaux_a2x + logical, optional, intent(OUT) :: histaux_a2x1hri + logical, optional, intent(OUT) :: histaux_a2x1hr + logical, optional, intent(OUT) :: histaux_a2x3hr + logical, optional, intent(OUT) :: histaux_a2x3hrp + logical, optional, intent(OUT) :: histaux_a2x24hr + logical, optional, intent(OUT) :: histaux_l2x1yr + logical, optional, intent(OUT) :: histaux_l2x + logical, optional, intent(OUT) :: histaux_r2x + logical, optional, intent(OUT) :: histavg_atm + logical, optional, intent(OUT) :: histavg_lnd + logical, optional, intent(OUT) :: histavg_ocn + logical, optional, intent(OUT) :: histavg_ice + logical, optional, intent(OUT) :: histavg_rof + logical, optional, intent(OUT) :: histavg_glc + logical, optional, intent(OUT) :: histavg_wav + logical, optional, intent(OUT) :: histavg_xao + logical, optional, intent(OUT) :: drv_threading ! driver threading control flag + real(SHR_KIND_R8), optional, intent(OUT) :: eps_frac ! fraction error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_amask ! atm mask error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_agrid ! atm grid error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_aarea ! atm area error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_omask ! ocn mask error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_ogrid ! ocn grid error tolerance + real(SHR_KIND_R8), optional, intent(OUT) :: eps_oarea ! ocn area error tolerance + logical, optional, intent(OUT) :: reprosum_use_ddpdd ! use ddpdd algorithm + real(SHR_KIND_R8), optional, intent(OUT) :: reprosum_diffmax ! maximum difference tolerance + logical, optional, intent(OUT) :: reprosum_recompute ! recompute if tolerance exceeded + logical, optional, intent(OUT) :: mct_usealltoall ! flag for mct alltoall + logical, optional, intent(OUT) :: mct_usevector ! flag for mct vector + + integer(SHR_KIND_IN), optional, intent(OUT) :: info_debug + logical, optional, intent(OUT) :: bfbflag + logical, optional, intent(OUT) :: esmf_map_flag + logical, optional, intent(OUT) :: dead_comps ! do we have dead models + + logical, optional, intent(OUT) :: atm_present ! provide data + logical, optional, intent(OUT) :: atm_prognostic ! need data + logical, optional, intent(OUT) :: lnd_present + logical, optional, intent(OUT) :: lnd_prognostic + logical, optional, intent(OUT) :: rof_present + logical, optional, intent(OUT) :: rofice_present + logical, optional, intent(OUT) :: rof_prognostic + logical, optional, intent(OUT) :: flood_present + logical, optional, intent(OUT) :: ocn_present + logical, optional, intent(OUT) :: ocn_prognostic + logical, optional, intent(OUT) :: ocnrof_prognostic + logical, optional, intent(OUT) :: ice_present + logical, optional, intent(OUT) :: ice_prognostic + logical, optional, intent(OUT) :: iceberg_prognostic + logical, optional, intent(OUT) :: glc_present + logical, optional, intent(OUT) :: glclnd_present + logical, optional, intent(OUT) :: glcocn_present + logical, optional, intent(OUT) :: glcice_present + logical, optional, intent(OUT) :: glc_prognostic + logical, optional, intent(OUT) :: glc_coupled_fluxes + logical, optional, intent(OUT) :: wav_present + logical, optional, intent(OUT) :: wav_prognostic + logical, optional, intent(OUT) :: esp_present + logical, optional, intent(OUT) :: esp_prognostic + integer(SHR_KIND_IN), optional, intent(OUT) :: atm_nx ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(OUT) :: atm_ny ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(OUT) :: lnd_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: lnd_ny + integer(SHR_KIND_IN), optional, intent(OUT) :: rof_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: rof_ny + integer(SHR_KIND_IN), optional, intent(OUT) :: ice_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: ice_ny + integer(SHR_KIND_IN), optional, intent(OUT) :: ocn_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: ocn_ny + integer(SHR_KIND_IN), optional, intent(OUT) :: glc_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: glc_ny + integer(SHR_KIND_IN), optional, intent(OUT) :: wav_nx + integer(SHR_KIND_IN), optional, intent(OUT) :: wav_ny + + real(SHR_KIND_R8), optional, intent(OUT) :: nextsw_cday ! calendar of next atm shortwave + real(SHR_KIND_R8), optional, intent(OUT) :: precip_fact ! precip factor + real(SHR_KIND_R8), optional, intent(OUT) :: flux_epbalfact ! adjusted precip factor + integer(SHR_KIND_IN), optional, intent(OUT) :: atm_phase ! atm phase + integer(SHR_KIND_IN), optional, intent(OUT) :: lnd_phase ! lnd phase + integer(SHR_KIND_IN), optional, intent(OUT) :: ice_phase ! ice phase + integer(SHR_KIND_IN), optional, intent(OUT) :: ocn_phase ! ocn phase + integer(SHR_KIND_IN), optional, intent(OUT) :: glc_phase ! glc phase + integer(SHR_KIND_IN), optional, intent(OUT) :: rof_phase ! rof phase + integer(SHR_KIND_IN), optional, intent(OUT) :: wav_phase ! wav phase + integer(SHR_KIND_IN), optional, intent(OUT) :: esp_phase ! wav phase + logical, optional, intent(OUT) :: atm_aero ! atmosphere aerosols + logical, optional, intent(OUT) :: glc_g2lupdate ! update glc2lnd fields in lnd model + real(shr_kind_r8), optional, intent(out) :: max_cplstep_time + logical, optional, intent(OUT) :: glc_valid_input + character(SHR_KIND_CL), optional, intent(OUT) :: atm_resume(:) ! atm read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: lnd_resume(:) ! lnd read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: ice_resume(:) ! ice read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: ocn_resume(:) ! ocn read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: glc_resume(:) ! glc read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: rof_resume(:) ! rof read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: wav_resume(:) ! wav read resume state + character(SHR_KIND_CL), optional, intent(OUT) :: cpl_resume ! cpl read resume state + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_GetData_explicit) ' + +!------------------------------------------------------------------------------- + + if ( present(cime_model) ) cime_model = infodata%cime_model + if ( present(start_type) ) start_type = infodata%start_type + if ( present(case_name) ) case_name = infodata%case_name + if ( present(case_desc) ) case_desc = infodata%case_desc + if ( present(model_version) ) model_version = infodata%model_version + if ( present(username) ) username = infodata%username + if ( present(hostname) ) hostname = infodata%hostname + if ( present(rest_case_name) ) rest_case_name = infodata%rest_case_name + if ( present(timing_dir) ) timing_dir = infodata%timing_dir + if ( present(tchkpt_dir) ) tchkpt_dir = infodata%tchkpt_dir + if ( present(aqua_planet) ) aqua_planet = infodata%aqua_planet + if ( present(aqua_planet_sst)) aqua_planet_sst= infodata%aqua_planet_sst + if ( present(run_barriers) ) run_barriers = infodata%run_barriers + if ( present(brnch_retain_casename) ) & + brnch_retain_casename = infodata%brnch_retain_casename + if ( present(read_restart) ) read_restart = infodata%read_restart + if ( present(restart_pfile) ) restart_pfile = infodata%restart_pfile + if ( present(restart_file) ) restart_file = infodata%restart_file + if ( present(single_column) ) single_column = infodata%single_column + if ( present(scmlat) ) scmlat = infodata%scmlat + if ( present(scmlon) ) scmlon = infodata%scmlon + if ( present(logFilePostFix) ) logFilePostFix = infodata%logFilePostFix + if ( present(outPathRoot) ) outPathRoot = infodata%outPathRoot + if ( present(perpetual) ) perpetual = infodata%perpetual + if ( present(perpetual_ymd) ) perpetual_ymd = infodata%perpetual_ymd + if ( present(orb_iyear) ) orb_iyear = infodata%orb_iyear + if ( present(orb_iyear_align)) orb_iyear_align= infodata%orb_iyear_align + if ( present(orb_mode) ) orb_mode = infodata%orb_mode + if ( present(orb_eccen) ) orb_eccen = infodata%orb_eccen + if ( present(orb_obliqr) ) orb_obliqr = infodata%orb_obliqr + if ( present(orb_obliq) ) orb_obliq = infodata%orb_obliq + if ( present(orb_lambm0) ) orb_lambm0 = infodata%orb_lambm0 + if ( present(orb_mvelpp) ) orb_mvelpp = infodata%orb_mvelpp + if ( present(orb_mvelp) ) orb_mvelp = infodata%orb_mvelp + if ( present(wv_sat_scheme) ) wv_sat_scheme = infodata%wv_sat_scheme + if ( present(wv_sat_transition_start)) & + wv_sat_transition_start = infodata%wv_sat_transition_start + if ( present(wv_sat_use_tables)) wv_sat_use_tables = infodata%wv_sat_use_tables + if ( present(wv_sat_table_spacing)) wv_sat_table_spacing = infodata%wv_sat_table_spacing + if ( present(tfreeze_option) ) tfreeze_option = infodata%tfreeze_option + if ( present(flux_epbal) ) flux_epbal = infodata%flux_epbal + if ( present(flux_albav) ) flux_albav = infodata%flux_albav + if ( present(flux_diurnal) ) flux_diurnal = infodata%flux_diurnal + if ( present(gust_fac) ) gust_fac = infodata%gust_fac + if ( present(glc_renormalize_smb)) glc_renormalize_smb = infodata%glc_renormalize_smb + if ( present(wall_time_limit)) wall_time_limit= infodata%wall_time_limit + if ( present(force_stop_at) ) force_stop_at = infodata%force_stop_at + if ( present(atm_gnam) ) atm_gnam = infodata%atm_gnam + if ( present(lnd_gnam) ) lnd_gnam = infodata%lnd_gnam + if ( present(ocn_gnam) ) ocn_gnam = infodata%ocn_gnam + if ( present(ice_gnam) ) ice_gnam = infodata%ice_gnam + if ( present(rof_gnam) ) rof_gnam = infodata%rof_gnam + if ( present(glc_gnam) ) glc_gnam = infodata%glc_gnam + if ( present(wav_gnam) ) wav_gnam = infodata%wav_gnam + if ( present(shr_map_dopole) ) shr_map_dopole = infodata%shr_map_dopole + if ( present(vect_map) ) vect_map = infodata%vect_map + if ( present(aoflux_grid) ) aoflux_grid = infodata%aoflux_grid + if ( present(cpl_decomp) ) cpl_decomp = infodata%cpl_decomp + if ( present(cpl_seq_option) ) cpl_seq_option = infodata%cpl_seq_option + if ( present(do_budgets) ) do_budgets = infodata%do_budgets + if ( present(do_histinit) ) do_histinit = infodata%do_histinit + if ( present(budget_inst) ) budget_inst = infodata%budget_inst + if ( present(budget_daily) ) budget_daily = infodata%budget_daily + if ( present(budget_month) ) budget_month = infodata%budget_month + if ( present(budget_ann) ) budget_ann = infodata%budget_ann + if ( present(budget_ltann) ) budget_ltann = infodata%budget_ltann + if ( present(budget_ltend) ) budget_ltend = infodata%budget_ltend + if ( present(histaux_a2x) ) histaux_a2x = infodata%histaux_a2x + if ( present(histaux_a2x1hri)) histaux_a2x1hri= infodata%histaux_a2x1hri + if ( present(histaux_a2x1hr) ) histaux_a2x1hr = infodata%histaux_a2x1hr + if ( present(histaux_a2x3hr) ) histaux_a2x3hr = infodata%histaux_a2x3hr + if ( present(histaux_a2x3hrp)) histaux_a2x3hrp= infodata%histaux_a2x3hrp + if ( present(histaux_a2x24hr)) histaux_a2x24hr= infodata%histaux_a2x24hr + if ( present(histaux_l2x1yr) ) histaux_l2x1yr = infodata%histaux_l2x1yr + if ( present(histaux_l2x) ) histaux_l2x = infodata%histaux_l2x + if ( present(histaux_r2x) ) histaux_r2x = infodata%histaux_r2x + if ( present(histavg_atm) ) histavg_atm = infodata%histavg_atm + if ( present(histavg_lnd) ) histavg_lnd = infodata%histavg_lnd + if ( present(histavg_ocn) ) histavg_ocn = infodata%histavg_ocn + if ( present(histavg_ice) ) histavg_ice = infodata%histavg_ice + if ( present(histavg_rof) ) histavg_rof = infodata%histavg_rof + if ( present(histavg_glc) ) histavg_glc = infodata%histavg_glc + if ( present(histavg_wav) ) histavg_wav = infodata%histavg_wav + if ( present(histavg_xao) ) histavg_xao = infodata%histavg_xao + if ( present(drv_threading) ) drv_threading = infodata%drv_threading + if ( present(eps_frac) ) eps_frac = infodata%eps_frac + if ( present(eps_amask) ) eps_amask = infodata%eps_amask + if ( present(eps_agrid) ) eps_agrid = infodata%eps_agrid + if ( present(eps_aarea) ) eps_aarea = infodata%eps_aarea + if ( present(eps_omask) ) eps_omask = infodata%eps_omask + if ( present(eps_ogrid) ) eps_ogrid = infodata%eps_ogrid + if ( present(eps_oarea) ) eps_oarea = infodata%eps_oarea + if ( present(reprosum_use_ddpdd)) reprosum_use_ddpdd = infodata%reprosum_use_ddpdd + if ( present(reprosum_diffmax) ) reprosum_diffmax = infodata%reprosum_diffmax + if ( present(reprosum_recompute)) reprosum_recompute = infodata%reprosum_recompute + if ( present(mct_usealltoall)) mct_usealltoall = infodata%mct_usealltoall + if ( present(mct_usevector) ) mct_usevector = infodata%mct_usevector + + if ( present(info_debug) ) info_debug = infodata%info_debug + if ( present(bfbflag) ) bfbflag = infodata%bfbflag + if ( present(esmf_map_flag) ) esmf_map_flag = infodata%esmf_map_flag + if ( present(dead_comps) ) dead_comps = infodata%dead_comps + + if ( present(atm_present) ) atm_present = infodata%atm_present + if ( present(atm_prognostic) ) atm_prognostic = infodata%atm_prognostic + if ( present(lnd_present) ) lnd_present = infodata%lnd_present + if ( present(lnd_prognostic) ) lnd_prognostic = infodata%lnd_prognostic + if ( present(rof_present) ) rof_present = infodata%rof_present + if ( present(rofice_present) ) rofice_present = infodata%rofice_present + if ( present(rof_prognostic) ) rof_prognostic = infodata%rof_prognostic + if ( present(flood_present) ) flood_present = infodata%flood_present + if ( present(ocn_present) ) ocn_present = infodata%ocn_present + if ( present(ocn_prognostic) ) ocn_prognostic = infodata%ocn_prognostic + if ( present(ocnrof_prognostic) ) ocnrof_prognostic = infodata%ocnrof_prognostic + if ( present(ice_present) ) ice_present = infodata%ice_present + if ( present(ice_prognostic) ) ice_prognostic = infodata%ice_prognostic + if ( present(iceberg_prognostic)) iceberg_prognostic = infodata%iceberg_prognostic + if ( present(glc_present) ) glc_present = infodata%glc_present + if ( present(glclnd_present) ) glclnd_present = infodata%glclnd_present + if ( present(glcocn_present) ) glcocn_present = infodata%glcocn_present + if ( present(glcice_present) ) glcice_present = infodata%glcice_present + if ( present(glc_prognostic) ) glc_prognostic = infodata%glc_prognostic + if ( present(glc_coupled_fluxes)) glc_coupled_fluxes = infodata%glc_coupled_fluxes + if ( present(wav_present) ) wav_present = infodata%wav_present + if ( present(wav_prognostic) ) wav_prognostic = infodata%wav_prognostic + if ( present(esp_present) ) esp_present = infodata%esp_present + if ( present(esp_prognostic) ) esp_prognostic = infodata%esp_prognostic + if ( present(atm_nx) ) atm_nx = infodata%atm_nx + if ( present(atm_ny) ) atm_ny = infodata%atm_ny + if ( present(lnd_nx) ) lnd_nx = infodata%lnd_nx + if ( present(lnd_ny) ) lnd_ny = infodata%lnd_ny + if ( present(rof_nx) ) rof_nx = infodata%rof_nx + if ( present(rof_ny) ) rof_ny = infodata%rof_ny + if ( present(ice_nx) ) ice_nx = infodata%ice_nx + if ( present(ice_ny) ) ice_ny = infodata%ice_ny + if ( present(ocn_nx) ) ocn_nx = infodata%ocn_nx + if ( present(ocn_ny) ) ocn_ny = infodata%ocn_ny + if ( present(glc_nx) ) glc_nx = infodata%glc_nx + if ( present(glc_ny) ) glc_ny = infodata%glc_ny + if ( present(wav_nx) ) wav_nx = infodata%wav_nx + if ( present(wav_ny) ) wav_ny = infodata%wav_ny + + if ( present(nextsw_cday) ) nextsw_cday = infodata%nextsw_cday + if ( present(precip_fact) ) precip_fact = infodata%precip_fact + if ( present(flux_epbalfact) ) then + flux_epbalfact = 1.0_SHR_KIND_R8 + if (trim(infodata%flux_epbal) == 'ocn') then + flux_epbalfact = infodata%precip_fact + end if + if (flux_epbalfact <= 0.0_SHR_KIND_R8) then + if (loglevel > 0) write(logunit,'(2a,e16.6)') & + trim(subname),' WARNING: factor from ocn = ',flux_epbalfact + if (loglevel > 0) write(logunit,'(2a)') & + trim(subname),' WARNING: resetting flux_epbalfact to 1.0' + flux_epbalfact = 1.0_SHR_KIND_R8 + end if + endif + if ( present(atm_phase) ) atm_phase = infodata%atm_phase + if ( present(lnd_phase) ) lnd_phase = infodata%lnd_phase + if ( present(ice_phase) ) ice_phase = infodata%ice_phase + if ( present(ocn_phase) ) ocn_phase = infodata%ocn_phase + if ( present(glc_phase) ) glc_phase = infodata%glc_phase + if ( present(rof_phase) ) rof_phase = infodata%rof_phase + if ( present(wav_phase) ) wav_phase = infodata%wav_phase + if ( present(esp_phase) ) esp_phase = infodata%esp_phase + if ( present(atm_aero) ) atm_aero = infodata%atm_aero + if ( present(glc_g2lupdate) ) glc_g2lupdate = infodata%glc_g2lupdate + if ( present(atm_resume) ) then + if (associated(infodata%pause_resume)) then + atm_resume(:) = infodata%pause_resume%atm_resume(:) + else + atm_resume(:) = ' ' + end if + end if + if ( present(lnd_resume) ) then + if (associated(infodata%pause_resume)) then + lnd_resume(:) = infodata%pause_resume%lnd_resume(:) + else + lnd_resume(:) = ' ' + end if + end if + if ( present(ice_resume) ) then + if (associated(infodata%pause_resume)) then + ice_resume(:) = infodata%pause_resume%ice_resume(:) + else + ice_resume(:) = ' ' + end if + end if + if ( present(ocn_resume) ) then + if (associated(infodata%pause_resume)) then + ocn_resume(:) = infodata%pause_resume%ocn_resume(:) + else + ocn_resume(:) = ' ' + end if + end if + if ( present(glc_resume) ) then + if (associated(infodata%pause_resume)) then + glc_resume(:) = infodata%pause_resume%glc_resume(:) + else + glc_resume(:) = ' ' + end if + end if + if ( present(rof_resume) ) then + if (associated(infodata%pause_resume)) then + rof_resume(:) = infodata%pause_resume%rof_resume(:) + else + rof_resume(:) = ' ' + end if + end if + if ( present(wav_resume) ) then + if (associated(infodata%pause_resume)) then + wav_resume(:) = infodata%pause_resume%wav_resume(:) + else + wav_resume(:) = ' ' + end if + end if + if ( present(cpl_resume) ) then + if (associated(infodata%pause_resume)) then + cpl_resume = infodata%pause_resume%cpl_resume + else + cpl_resume = ' ' + end if + end if + if ( present(max_cplstep_time) ) max_cplstep_time = infodata%max_cplstep_time + if ( present(glc_valid_input)) glc_valid_input = infodata%glc_valid_input + +END SUBROUTINE seq_infodata_GetData_explicit + +#ifndef CPRPGI +!=============================================================================== +! !IROUTINE: seq_infodata_GetData_bytype -- Get values from infodata object +! +! !DESCRIPTION: +! +! Get values out of the infodata object. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_GetData_bytype( component_firstletter, infodata, & + comp_present, comp_prognostic, comp_gnam, histavg_comp, & + comp_phase, comp_nx, comp_ny, comp_resume) + + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(len=1), intent(IN) :: component_firstletter + type(seq_infodata_type), intent(IN) :: infodata ! Input CCSM structure + logical, optional, intent(OUT) :: comp_present ! provide data + logical, optional, intent(OUT) :: comp_prognostic ! need data + character(len=*), optional, intent(OUT) :: comp_gnam ! comp grid + integer(SHR_KIND_IN), optional, intent(OUT) :: comp_nx ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(OUT) :: comp_ny ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(OUT) :: comp_phase + logical, optional, intent(OUT) :: histavg_comp + character(SHR_KIND_CL), optional, intent(OUT) :: comp_resume(:) + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_GetData_bytype) ' + +!------------------------------------------------------------------------------- + + if (component_firstletter == 'a') then + call seq_infodata_GetData(infodata, atm_present=comp_present, & + atm_prognostic=comp_prognostic, atm_gnam=comp_gnam, & + atm_phase=comp_phase, atm_nx=comp_nx, atm_ny=comp_ny, & + histavg_atm=histavg_comp, atm_resume=comp_resume) + else if (component_firstletter == 'l') then + call seq_infodata_GetData(infodata, lnd_present=comp_present, & + lnd_prognostic=comp_prognostic, lnd_gnam=comp_gnam, & + lnd_phase=comp_phase, lnd_nx=comp_nx, lnd_ny=comp_ny, & + histavg_lnd=histavg_comp, lnd_resume=comp_resume) + else if (component_firstletter == 'i') then + call seq_infodata_GetData(infodata, ice_present=comp_present, & + ice_prognostic=comp_prognostic, ice_gnam=comp_gnam, & + ice_phase=comp_phase, ice_nx=comp_nx, ice_ny=comp_ny, & + histavg_ice=histavg_comp, ice_resume=comp_resume) + else if (component_firstletter == 'o') then + call seq_infodata_GetData(infodata, ocn_present=comp_present, & + ocn_prognostic=comp_prognostic, ocn_gnam=comp_gnam, & + ocn_phase=comp_phase, ocn_nx=comp_nx, ocn_ny=comp_ny, & + histavg_ocn=histavg_comp, ocn_resume=comp_resume) + else if (component_firstletter == 'r') then + call seq_infodata_GetData(infodata, rof_present=comp_present, & + rof_prognostic=comp_prognostic, rof_gnam=comp_gnam, & + rof_phase=comp_phase, rof_nx=comp_nx, rof_ny=comp_ny, & + histavg_rof=histavg_comp, rof_resume=comp_resume) + else if (component_firstletter == 'g') then + call seq_infodata_GetData(infodata, glc_present=comp_present, & + glc_prognostic=comp_prognostic, glc_gnam=comp_gnam, & + glc_phase=comp_phase, glc_nx=comp_nx, glc_ny=comp_ny, & + histavg_glc=histavg_comp, glc_resume=comp_resume) + else if (component_firstletter == 'w') then + call seq_infodata_GetData(infodata, wav_present=comp_present, & + wav_prognostic=comp_prognostic, wav_gnam=comp_gnam, & + wav_phase=comp_phase, wav_nx=comp_nx, wav_ny=comp_ny, & + histavg_wav=histavg_comp, wav_resume=comp_resume) + else if (component_firstletter == 'e') then + if (present(comp_gnam)) then + comp_gnam = '' + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + write(logunit,*) trim(subname),' Note: ESP type has no gnam property' + end if + end if + if (present(comp_nx)) then + comp_nx = 1 + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + write(logunit,*) trim(subname),' Note: ESP type has no nx property' + end if + end if + if (present(comp_ny)) then + comp_ny = 1 + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + write(logunit,*) trim(subname),' Note: ESP type has no ny property' + end if + end if + if (present(histavg_comp)) then + histavg_comp = .false. + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + write(logunit,*) trim(subname),' Note: ESP type has no histavg property' + end if + end if + if (present(comp_resume)) then + comp_resume = ' ' + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + write(logunit,*) trim(subname),' Note: ESP type has no resume property' + end if + end if + + call seq_infodata_GetData(infodata, esp_present=comp_present, & + esp_prognostic=comp_prognostic, esp_phase=comp_phase) + else + call shr_sys_abort( subname//": unknown component-type first letter,'"//component_firstletter//"', aborting") + end if + END SUBROUTINE seq_infodata_GetData_bytype +#endif +! ^ ifndef CPRPGI + +!=============================================================================== +! !IROUTINE: seq_infodata_PutData_explicit -- Put values into infodata object +! +! !DESCRIPTION: +! +! Put values into the infodata object. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_PutData_explicit( infodata, cime_model, case_name, case_desc, timing_dir, & + model_version, username, hostname, rest_case_name, tchkpt_dir, & + start_type, restart_pfile, restart_file, perpetual, perpetual_ymd, & + aqua_planet,aqua_planet_sst, brnch_retain_casename, & + single_column, scmlat,scmlon,logFilePostFix, outPathRoot, & + atm_present, atm_prognostic, lnd_present, lnd_prognostic, rof_prognostic, & + rof_present, ocn_present, ocn_prognostic, ocnrof_prognostic, & + ice_present, ice_prognostic, glc_present, glc_prognostic, & + glc_coupled_fluxes, & + flood_present, wav_present, wav_prognostic, rofice_present, & + glclnd_present, glcocn_present, glcice_present, iceberg_prognostic,& + esp_present, esp_prognostic, & + bfbflag, lnd_gnam, cpl_decomp, cpl_seq_option, & + ice_gnam, rof_gnam, glc_gnam, wav_gnam, & + atm_gnam, ocn_gnam, info_debug, dead_comps, read_restart, & + shr_map_dopole, vect_map, aoflux_grid, run_barriers, & + nextsw_cday, precip_fact, flux_epbal, flux_albav, & + glc_g2lupdate, atm_aero, esmf_map_flag, wall_time_limit, & + do_budgets, do_histinit, drv_threading, flux_diurnal, gust_fac, & + budget_inst, budget_daily, budget_month, force_stop_at, & + budget_ann, budget_ltann, budget_ltend , & + histaux_a2x , histaux_a2x1hri, histaux_a2x1hr, & + histaux_a2x3hr, histaux_a2x3hrp , histaux_l2x1yr, & + histaux_a2x24hr, histaux_l2x , histaux_r2x , orb_obliq, & + histavg_atm, histavg_lnd, histavg_ocn, histavg_ice, & + histavg_rof, histavg_glc, histavg_wav, histavg_xao, & + orb_iyear, orb_iyear_align, orb_mode, orb_mvelp, & + orb_eccen, orb_obliqr, orb_lambm0, orb_mvelpp, wv_sat_scheme, & + wv_sat_transition_start, wv_sat_use_tables, wv_sat_table_spacing, & + tfreeze_option, glc_renormalize_smb, & + glc_phase, rof_phase, atm_phase, lnd_phase, ocn_phase, ice_phase, & + wav_phase, esp_phase, wav_nx, wav_ny, atm_nx, atm_ny, & + lnd_nx, lnd_ny, rof_nx, rof_ny, ice_nx, ice_ny, ocn_nx, ocn_ny, & + glc_nx, glc_ny, eps_frac, eps_amask, & + eps_agrid, eps_aarea, eps_omask, eps_ogrid, eps_oarea, & + reprosum_use_ddpdd, reprosum_diffmax, reprosum_recompute, & + atm_resume, lnd_resume, ocn_resume, ice_resume, & + glc_resume, rof_resume, wav_resume, cpl_resume, & + mct_usealltoall, mct_usevector, glc_valid_input) + + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! Input CCSM structure + character(len=*), optional, intent(IN) :: cime_model ! CIME model (acme or cesm) + character(len=*), optional, intent(IN) :: start_type ! Start type + character(len=*), optional, intent(IN) :: case_name ! Short case identification + character(len=*), optional, intent(IN) :: case_desc ! Long case description + character(len=*), optional, intent(IN) :: model_version ! Model version + character(len=*), optional, intent(IN) :: username ! Username + character(len=*), optional, intent(IN) :: hostname ! Hostname + character(len=*), optional, intent(IN) :: rest_case_name ! restart casename + character(len=*), optional, intent(IN) :: timing_dir ! timing dir name + character(len=*), optional, intent(IN) :: tchkpt_dir ! timing checkpoint dir name + logical, optional, intent(IN) :: aqua_planet ! aqua_planet mode + integer(SHR_KIND_IN), optional, intent(IN) :: aqua_planet_sst ! aqua_planet sst type + logical, optional, intent(IN) :: run_barriers ! barrier component run calls + logical, optional, intent(IN) :: brnch_retain_casename + logical, optional, intent(IN) :: read_restart ! read restart flag + character(len=*), optional, intent(IN) :: restart_pfile ! Restart pointer file + character(len=*), optional, intent(IN) :: restart_file ! Restart file pathname + logical, optional, intent(IN) :: single_column + real (SHR_KIND_R8), optional, intent(IN) :: scmlat + real (SHR_KIND_R8), optional, intent(IN) :: scmlon + character(len=*), optional, intent(IN) :: logFilePostFix ! output log file postfix + character(len=*), optional, intent(IN) :: outPathRoot ! output file root + logical, optional, intent(IN) :: perpetual ! If this is perpetual + integer, optional, intent(IN) :: perpetual_ymd ! If perpetual, date + character(len=*), optional, intent(IN) :: orb_mode ! orbital mode + integer, optional, intent(IN) :: orb_iyear ! orbital year + integer, optional, intent(IN) :: orb_iyear_align ! orbital year model year align + real(SHR_KIND_R8), optional, intent(IN) :: orb_eccen ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(IN) :: orb_obliqr ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(IN) :: orb_obliq ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(IN) :: orb_lambm0 ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(IN) :: orb_mvelpp ! See shr_orb_mod + real(SHR_KIND_R8), optional, intent(IN) :: orb_mvelp ! See shr_orb_mod + character(len=*), optional, intent(IN) :: wv_sat_scheme ! Water vapor saturation pressure scheme + real(SHR_KIND_R8), optional, intent(IN) :: wv_sat_transition_start ! Saturation transition range + logical, optional, intent(IN) :: wv_sat_use_tables ! Saturation pressure lookup tables + real(SHR_KIND_R8), optional, intent(IN) :: wv_sat_table_spacing ! Saturation pressure table resolution + character(len=*), optional, intent(IN) :: tfreeze_option ! Freezing point of salt water + character(len=*), optional, intent(IN) :: flux_epbal ! selects E,P,R adjustment technique + logical, optional, intent(IN) :: flux_albav ! T => no diurnal cycle in ocn albedos + logical, optional, intent(IN) :: flux_diurnal ! T => diurnal cycle in atm/ocn flux + real(SHR_KIND_R8), optional, intent(IN) :: gust_fac ! wind gustiness factor + character(len=*), optional, intent(IN) :: glc_renormalize_smb ! Whether to renormalize smb sent from lnd -> glc + real(SHR_KIND_R8), optional, intent(IN) :: wall_time_limit ! force stop wall time (hours) + character(len=*), optional, intent(IN) :: force_stop_at ! force a stop at next (month, day, etc) + character(len=*), optional, intent(IN) :: atm_gnam ! atm grid + character(len=*), optional, intent(IN) :: lnd_gnam ! lnd grid + character(len=*), optional, intent(IN) :: ocn_gnam ! ocn grid + character(len=*), optional, intent(IN) :: ice_gnam ! ice grid + character(len=*), optional, intent(IN) :: rof_gnam ! rof grid + character(len=*), optional, intent(IN) :: glc_gnam ! glc grid + character(len=*), optional, intent(IN) :: wav_gnam ! wav grid + logical, optional, intent(IN) :: shr_map_dopole ! pole corrections in shr_map_mod + character(len=*), optional, intent(IN) :: vect_map ! vector mapping option + character(len=*), optional, intent(IN) :: aoflux_grid ! grid for atm ocn flux calc + integer, optional, intent(IN) :: cpl_decomp ! coupler decomp + character(len=*), optional, intent(IN) :: cpl_seq_option ! coupler sequencing option + logical, optional, intent(IN) :: do_budgets ! heat/water budgets + logical, optional, intent(IN) :: do_histinit ! initial history file + integer, optional, intent(IN) :: budget_inst ! inst budget + integer, optional, intent(IN) :: budget_daily ! daily budget + integer, optional, intent(IN) :: budget_month ! month budget + integer, optional, intent(IN) :: budget_ann ! ann budget + integer, optional, intent(IN) :: budget_ltann ! ltann budget + integer, optional, intent(IN) :: budget_ltend ! ltend budget + logical, optional, intent(IN) :: histaux_a2x + logical, optional, intent(IN) :: histaux_a2x1hri + logical, optional, intent(IN) :: histaux_a2x1hr + logical, optional, intent(IN) :: histaux_a2x3hr + logical, optional, intent(IN) :: histaux_a2x3hrp + logical, optional, intent(IN) :: histaux_a2x24hr + logical, optional, intent(IN) :: histaux_l2x1yr + logical, optional, intent(IN) :: histaux_l2x + logical, optional, intent(IN) :: histaux_r2x + logical, optional, intent(IN) :: histavg_atm + logical, optional, intent(IN) :: histavg_lnd + logical, optional, intent(IN) :: histavg_ocn + logical, optional, intent(IN) :: histavg_ice + logical, optional, intent(IN) :: histavg_rof + logical, optional, intent(IN) :: histavg_glc + logical, optional, intent(IN) :: histavg_wav + logical, optional, intent(IN) :: histavg_xao + logical, optional, intent(IN) :: drv_threading ! driver threading control flag + real(SHR_KIND_R8), optional, intent(IN) :: eps_frac ! fraction error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_amask ! atm mask error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_agrid ! atm grid error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_aarea ! atm area error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_omask ! ocn mask error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_ogrid ! ocn grid error tolerance + real(SHR_KIND_R8), optional, intent(IN) :: eps_oarea ! ocn area error tolerance + logical, optional, intent(IN) :: reprosum_use_ddpdd ! use ddpdd algorithm + real(SHR_KIND_R8), optional, intent(IN) :: reprosum_diffmax ! maximum difference tolerance + logical, optional, intent(IN) :: reprosum_recompute ! recompute if tolerance exceeded + logical, optional, intent(IN) :: mct_usealltoall ! flag for mct alltoall + logical, optional, intent(IN) :: mct_usevector ! flag for mct vector + + integer(SHR_KIND_IN), optional, intent(IN) :: info_debug + logical, optional, intent(IN) :: bfbflag + logical, optional, intent(IN) :: esmf_map_flag + logical, optional, intent(IN) :: dead_comps ! do we have dead models + + logical, optional, intent(IN) :: atm_present ! provide data + logical, optional, intent(IN) :: atm_prognostic ! need data + logical, optional, intent(IN) :: lnd_present + logical, optional, intent(IN) :: lnd_prognostic + logical, optional, intent(IN) :: rof_present + logical, optional, intent(IN) :: rofice_present + logical, optional, intent(IN) :: rof_prognostic + logical, optional, intent(IN) :: flood_present + logical, optional, intent(IN) :: ocn_present + logical, optional, intent(IN) :: ocn_prognostic + logical, optional, intent(IN) :: ocnrof_prognostic + logical, optional, intent(IN) :: ice_present + logical, optional, intent(IN) :: ice_prognostic + logical, optional, intent(IN) :: iceberg_prognostic + logical, optional, intent(IN) :: glc_present + logical, optional, intent(IN) :: glclnd_present + logical, optional, intent(IN) :: glcocn_present + logical, optional, intent(IN) :: glcice_present + logical, optional, intent(IN) :: glc_prognostic + logical, optional, intent(IN) :: glc_coupled_fluxes + logical, optional, intent(IN) :: wav_present + logical, optional, intent(IN) :: wav_prognostic + logical, optional, intent(IN) :: esp_present + logical, optional, intent(IN) :: esp_prognostic + integer(SHR_KIND_IN), optional, intent(IN) :: atm_nx ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(IN) :: atm_ny ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(IN) :: lnd_nx + integer(SHR_KIND_IN), optional, intent(IN) :: lnd_ny + integer(SHR_KIND_IN), optional, intent(IN) :: rof_nx + integer(SHR_KIND_IN), optional, intent(IN) :: rof_ny + integer(SHR_KIND_IN), optional, intent(IN) :: ice_nx + integer(SHR_KIND_IN), optional, intent(IN) :: ice_ny + integer(SHR_KIND_IN), optional, intent(IN) :: ocn_nx + integer(SHR_KIND_IN), optional, intent(IN) :: ocn_ny + integer(SHR_KIND_IN), optional, intent(IN) :: glc_nx + integer(SHR_KIND_IN), optional, intent(IN) :: glc_ny + integer(SHR_KIND_IN), optional, intent(IN) :: wav_nx + integer(SHR_KIND_IN), optional, intent(IN) :: wav_ny + + real(SHR_KIND_R8), optional, intent(IN) :: nextsw_cday ! calendar of next atm shortwave + real(SHR_KIND_R8), optional, intent(IN) :: precip_fact ! precip factor + integer(SHR_KIND_IN), optional, intent(IN) :: atm_phase ! atm phase + integer(SHR_KIND_IN), optional, intent(IN) :: lnd_phase ! lnd phase + integer(SHR_KIND_IN), optional, intent(IN) :: ice_phase ! ice phase + integer(SHR_KIND_IN), optional, intent(IN) :: ocn_phase ! ocn phase + integer(SHR_KIND_IN), optional, intent(IN) :: glc_phase ! glc phase + integer(SHR_KIND_IN), optional, intent(IN) :: rof_phase ! rof phase + integer(SHR_KIND_IN), optional, intent(IN) :: wav_phase ! wav phase + integer(SHR_KIND_IN), optional, intent(IN) :: esp_phase ! esp phase + logical, optional, intent(IN) :: atm_aero ! atm aerosols + logical, optional, intent(IN) :: glc_g2lupdate ! update glc2lnd fields in lnd model + logical, optional, intent(IN) :: glc_valid_input + character(SHR_KIND_CL), optional, intent(IN) :: atm_resume(:) ! atm resume + character(SHR_KIND_CL), optional, intent(IN) :: lnd_resume(:) ! lnd resume + character(SHR_KIND_CL), optional, intent(IN) :: ice_resume(:) ! ice resume + character(SHR_KIND_CL), optional, intent(IN) :: ocn_resume(:) ! ocn resume + character(SHR_KIND_CL), optional, intent(IN) :: glc_resume(:) ! glc resume + character(SHR_KIND_CL), optional, intent(IN) :: rof_resume(:) ! rof resume + character(SHR_KIND_CL), optional, intent(IN) :: wav_resume(:) ! wav resume + character(SHR_KIND_CL), optional, intent(IN) :: cpl_resume ! cpl resume + +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_PutData_explicit) ' + +!------------------------------------------------------------------------------- + + if ( present(cime_model) ) infodata%cime_model = cime_model + if ( present(start_type) ) infodata%start_type = start_type + if ( present(case_name) ) infodata%case_name = case_name + if ( present(case_desc) ) infodata%case_desc = case_desc + if ( present(model_version) ) infodata%model_version = model_version + if ( present(username) ) infodata%username = username + if ( present(hostname) ) infodata%hostname = hostname + if ( present(rest_case_name) ) infodata%rest_case_name = rest_case_name + if ( present(timing_dir) ) infodata%timing_dir = timing_dir + if ( present(tchkpt_dir) ) infodata%tchkpt_dir = tchkpt_dir + if ( present(aqua_planet) ) infodata%aqua_planet = aqua_planet + if ( present(aqua_planet_sst)) infodata%aqua_planet_sst= aqua_planet_sst + if ( present(run_barriers) ) infodata%run_barriers = run_barriers + if ( present(brnch_retain_casename)) infodata%brnch_retain_casename = brnch_retain_casename + if ( present(read_restart) ) infodata%read_restart = read_restart + if ( present(restart_pfile) ) infodata%restart_pfile = restart_pfile + if ( present(restart_file) ) infodata%restart_file = restart_file + if ( present(single_column) ) infodata%single_column = single_column + if ( present(scmlat) ) infodata%scmlat = scmlat + if ( present(scmlon) ) infodata%scmlon = scmlon + if ( present(logFilePostFix) ) infodata%logFilePostFix = logFilePostFix + if ( present(outPathRoot) ) infodata%outPathRoot = outPathRoot + if ( present(perpetual) ) infodata%perpetual = perpetual + if ( present(perpetual_ymd) ) infodata%perpetual_ymd = perpetual_ymd + if ( present(orb_iyear) ) infodata%orb_iyear = orb_iyear + if ( present(orb_iyear_align)) infodata%orb_iyear_align= orb_iyear_align + if ( present(orb_mode) ) infodata%orb_mode = orb_mode + if ( present(orb_eccen) ) infodata%orb_eccen = orb_eccen + if ( present(orb_obliqr) ) infodata%orb_obliqr = orb_obliqr + if ( present(orb_obliq) ) infodata%orb_obliq = orb_obliq + if ( present(orb_lambm0) ) infodata%orb_lambm0 = orb_lambm0 + if ( present(orb_mvelpp) ) infodata%orb_mvelpp = orb_mvelpp + if ( present(orb_mvelp) ) infodata%orb_mvelp = orb_mvelp + if ( present(wv_sat_scheme) ) infodata%wv_sat_scheme = wv_sat_scheme + if ( present(wv_sat_transition_start)) & + infodata%wv_sat_transition_start = wv_sat_transition_start + if ( present(wv_sat_use_tables)) infodata%wv_sat_use_tables = wv_sat_use_tables + if ( present(wv_sat_table_spacing)) infodata%wv_sat_table_spacing = wv_sat_table_spacing + if ( present(tfreeze_option) ) infodata%tfreeze_option = tfreeze_option + if ( present(flux_epbal) ) infodata%flux_epbal = flux_epbal + if ( present(flux_albav) ) infodata%flux_albav = flux_albav + if ( present(flux_diurnal) ) infodata%flux_diurnal = flux_diurnal + if ( present(gust_fac) ) infodata%gust_fac = gust_fac + if ( present(glc_renormalize_smb)) infodata%glc_renormalize_smb = glc_renormalize_smb + if ( present(wall_time_limit)) infodata%wall_time_limit= wall_time_limit + if ( present(force_stop_at) ) infodata%force_stop_at = force_stop_at + if ( present(atm_gnam) ) infodata%atm_gnam = atm_gnam + if ( present(lnd_gnam) ) infodata%lnd_gnam = lnd_gnam + if ( present(ocn_gnam) ) infodata%ocn_gnam = ocn_gnam + if ( present(ice_gnam) ) infodata%ice_gnam = ice_gnam + if ( present(rof_gnam) ) infodata%rof_gnam = rof_gnam + if ( present(glc_gnam) ) infodata%glc_gnam = glc_gnam + if ( present(wav_gnam) ) infodata%wav_gnam = wav_gnam + if ( present(shr_map_dopole) ) infodata%shr_map_dopole = shr_map_dopole + if ( present(vect_map) ) infodata%vect_map = vect_map + if ( present(aoflux_grid) ) infodata%aoflux_grid = aoflux_grid + if ( present(cpl_decomp) ) infodata%cpl_decomp = cpl_decomp + if ( present(cpl_seq_option) ) infodata%cpl_seq_option = cpl_seq_option + if ( present(do_budgets) ) infodata%do_budgets = do_budgets + if ( present(do_histinit) ) infodata%do_histinit = do_histinit + if ( present(budget_inst) ) infodata%budget_inst = budget_inst + if ( present(budget_daily) ) infodata%budget_daily = budget_daily + if ( present(budget_month) ) infodata%budget_month = budget_month + if ( present(budget_ann) ) infodata%budget_ann = budget_ann + if ( present(budget_ltann) ) infodata%budget_ltann = budget_ltann + if ( present(budget_ltend) ) infodata%budget_ltend = budget_ltend + if ( present(histaux_a2x) ) infodata%histaux_a2x = histaux_a2x + if ( present(histaux_a2x1hri)) infodata%histaux_a2x1hri= histaux_a2x1hri + if ( present(histaux_a2x1hr) ) infodata%histaux_a2x1hr = histaux_a2x1hr + if ( present(histaux_a2x3hr) ) infodata%histaux_a2x3hr = histaux_a2x3hr + if ( present(histaux_a2x3hrp)) infodata%histaux_a2x3hrp= histaux_a2x3hrp + if ( present(histaux_a2x24hr)) infodata%histaux_a2x24hr= histaux_a2x24hr + if ( present(histaux_l2x1yr) ) infodata%histaux_l2x1yr = histaux_l2x1yr + if ( present(histaux_l2x) ) infodata%histaux_l2x = histaux_l2x + if ( present(histaux_r2x) ) infodata%histaux_r2x = histaux_r2x + if ( present(histavg_atm) ) infodata%histavg_atm = histavg_atm + if ( present(histavg_lnd) ) infodata%histavg_lnd = histavg_lnd + if ( present(histavg_ocn) ) infodata%histavg_ocn = histavg_ocn + if ( present(histavg_ice) ) infodata%histavg_ice = histavg_ice + if ( present(histavg_rof) ) infodata%histavg_rof = histavg_rof + if ( present(histavg_glc) ) infodata%histavg_glc = histavg_glc + if ( present(histavg_wav) ) infodata%histavg_wav = histavg_wav + if ( present(histavg_xao) ) infodata%histavg_xao = histavg_xao + if ( present(drv_threading) ) infodata%drv_threading = drv_threading + if ( present(eps_frac) ) infodata%eps_frac = eps_frac + if ( present(eps_amask) ) infodata%eps_amask = eps_amask + if ( present(eps_agrid) ) infodata%eps_agrid = eps_agrid + if ( present(eps_aarea) ) infodata%eps_aarea = eps_aarea + if ( present(eps_omask) ) infodata%eps_omask = eps_omask + if ( present(eps_ogrid) ) infodata%eps_ogrid = eps_ogrid + if ( present(eps_oarea) ) infodata%eps_oarea = eps_oarea + if ( present(reprosum_use_ddpdd)) infodata%reprosum_use_ddpdd = reprosum_use_ddpdd + if ( present(reprosum_diffmax) ) infodata%reprosum_diffmax = reprosum_diffmax + if ( present(reprosum_recompute)) infodata%reprosum_recompute = reprosum_recompute + if ( present(mct_usealltoall)) infodata%mct_usealltoall = mct_usealltoall + if ( present(mct_usevector) ) infodata%mct_usevector = mct_usevector + + if ( present(info_debug) ) infodata%info_debug = info_debug + if ( present(bfbflag) ) infodata%bfbflag = bfbflag + if ( present(esmf_map_flag) ) infodata%esmf_map_flag = esmf_map_flag + if ( present(dead_comps) ) infodata%dead_comps = dead_comps + + if ( present(atm_present) ) infodata%atm_present = atm_present + if ( present(atm_prognostic) ) infodata%atm_prognostic = atm_prognostic + if ( present(lnd_present) ) infodata%lnd_present = lnd_present + if ( present(lnd_prognostic) ) infodata%lnd_prognostic = lnd_prognostic + if ( present(rof_present) ) infodata%rof_present = rof_present + if ( present(rofice_present) ) infodata%rofice_present = rofice_present + if ( present(rof_prognostic) ) infodata%rof_prognostic = rof_prognostic + if ( present(flood_present) ) infodata%flood_present = flood_present + if ( present(ocn_present) ) infodata%ocn_present = ocn_present + if ( present(ocn_prognostic) ) infodata%ocn_prognostic = ocn_prognostic + if ( present(ocnrof_prognostic)) infodata%ocnrof_prognostic = ocnrof_prognostic + if ( present(ice_present) ) infodata%ice_present = ice_present + if ( present(ice_prognostic) ) infodata%ice_prognostic = ice_prognostic + if ( present(iceberg_prognostic)) infodata%iceberg_prognostic = iceberg_prognostic + if ( present(glc_present) ) infodata%glc_present = glc_present + if ( present(glclnd_present) ) infodata%glclnd_present = glclnd_present + if ( present(glcocn_present) ) infodata%glcocn_present = glcocn_present + if ( present(glcice_present) ) infodata%glcice_present = glcice_present + if ( present(glc_prognostic) ) infodata%glc_prognostic = glc_prognostic + if ( present(glc_coupled_fluxes)) infodata%glc_coupled_fluxes = glc_coupled_fluxes + if ( present(wav_present) ) infodata%wav_present = wav_present + if ( present(wav_prognostic) ) infodata%wav_prognostic = wav_prognostic + if ( present(esp_present) ) infodata%esp_present = esp_present + if ( present(esp_prognostic) ) infodata%esp_prognostic = esp_prognostic + if ( present(atm_nx) ) infodata%atm_nx = atm_nx + if ( present(atm_ny) ) infodata%atm_ny = atm_ny + if ( present(lnd_nx) ) infodata%lnd_nx = lnd_nx + if ( present(lnd_ny) ) infodata%lnd_ny = lnd_ny + if ( present(rof_nx) ) infodata%rof_nx = rof_nx + if ( present(rof_ny) ) infodata%rof_ny = rof_ny + if ( present(ice_nx) ) infodata%ice_nx = ice_nx + if ( present(ice_ny) ) infodata%ice_ny = ice_ny + if ( present(ocn_nx) ) infodata%ocn_nx = ocn_nx + if ( present(ocn_ny) ) infodata%ocn_ny = ocn_ny + if ( present(glc_nx) ) infodata%glc_nx = glc_nx + if ( present(glc_ny) ) infodata%glc_ny = glc_ny + if ( present(wav_nx) ) infodata%wav_nx = wav_nx + if ( present(wav_ny) ) infodata%wav_ny = wav_ny + + if ( present(nextsw_cday) ) infodata%nextsw_cday = nextsw_cday + if ( present(precip_fact) ) infodata%precip_fact = precip_fact + if ( present(atm_phase) ) infodata%atm_phase = atm_phase + if ( present(lnd_phase) ) infodata%lnd_phase = lnd_phase + if ( present(ice_phase) ) infodata%ice_phase = ice_phase + if ( present(ocn_phase) ) infodata%ocn_phase = ocn_phase + if ( present(glc_phase) ) infodata%glc_phase = glc_phase + if ( present(rof_phase) ) infodata%rof_phase = rof_phase + if ( present(wav_phase) ) infodata%wav_phase = wav_phase + if ( present(esp_phase) ) infodata%esp_phase = esp_phase + if ( present(atm_aero) ) infodata%atm_aero = atm_aero + if ( present(glc_g2lupdate) ) infodata%glc_g2lupdate = glc_g2lupdate + if ( present(glc_valid_input) ) infodata%glc_valid_input = glc_valid_input + if ( present(atm_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%atm_resume(:) = atm_resume(:) + else if (ANY(len_trim(atm_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%atm_resume(:) = atm_resume(:) + end if + end if + if ( present(lnd_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%lnd_resume(:) = lnd_resume(:) + else if (ANY(len_trim(lnd_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%lnd_resume(:) = lnd_resume(:) + end if + end if + if ( present(ice_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%ice_resume(:) = ice_resume(:) + else if (ANY(len_trim(ice_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%ice_resume(:) = ice_resume(:) + end if + end if + if ( present(ocn_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%ocn_resume(:) = ocn_resume(:) + else if (ANY(len_trim(ocn_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%ocn_resume(:) = ocn_resume(:) + end if + end if + if ( present(glc_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%glc_resume(:) = glc_resume(:) + else if (ANY(len_trim(glc_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%glc_resume(:) = glc_resume(:) + end if + end if + if ( present(rof_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%rof_resume(:) = rof_resume(:) + else if (ANY(len_trim(rof_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%rof_resume(:) = rof_resume(:) + end if + end if + if ( present(wav_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%wav_resume(:) = wav_resume(:) + else if (ANY(len_trim(wav_resume(:)) > 0)) then + allocate(infodata%pause_resume) + infodata%pause_resume%wav_resume(:) = wav_resume(:) + end if + end if + if ( present(cpl_resume) ) then + if (associated(infodata%pause_resume)) then + infodata%pause_resume%cpl_resume = cpl_resume + else if (len_trim(cpl_resume) > 0) then + allocate(infodata%pause_resume) + infodata%pause_resume%cpl_resume = cpl_resume + end if + end if + +END SUBROUTINE seq_infodata_PutData_explicit + +#ifndef CPRPGI +!=============================================================================== +! !IROUTINE: seq_infodata_PutData_bytype -- Put values into infodata object +! +! !DESCRIPTION: +! +! Put values into the infodata object. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_PutData_bytype( component_firstletter, infodata, & + comp_present, comp_prognostic, comp_gnam, & + histavg_comp, comp_phase, comp_nx, comp_ny, comp_resume) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(len=1), intent(IN) :: component_firstletter + type(seq_infodata_type), intent(INOUT) :: infodata ! Input CCSM structure + logical, optional, intent(IN) :: comp_present ! provide data + logical, optional, intent(IN) :: comp_prognostic ! need data + character(len=*), optional, intent(IN) :: comp_gnam ! comp grid + integer(SHR_KIND_IN), optional, intent(IN) :: comp_nx ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(IN) :: comp_ny ! nx,ny 2d grid size global + integer(SHR_KIND_IN), optional, intent(IN) :: comp_phase + logical, optional, intent(IN) :: histavg_comp + character(SHR_KIND_CL), optional, intent(IN) :: comp_resume(:) + +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_PutData_bytype) ' + +!------------------------------------------------------------------------------- + + if (component_firstletter == 'a') then + call seq_infodata_PutData(infodata, atm_present=comp_present, & + atm_prognostic=comp_prognostic, atm_gnam=comp_gnam, & + atm_phase=comp_phase, atm_nx=comp_nx, atm_ny=comp_ny, & + histavg_atm=histavg_comp, atm_resume=comp_resume) + else if (component_firstletter == 'l') then + call seq_infodata_PutData(infodata, lnd_present=comp_present, & + lnd_prognostic=comp_prognostic, lnd_gnam=comp_gnam, & + lnd_phase=comp_phase, lnd_nx=comp_nx, lnd_ny=comp_ny, & + histavg_lnd=histavg_comp, lnd_resume=comp_resume) + else if (component_firstletter == 'i') then + call seq_infodata_PutData(infodata, ice_present=comp_present, & + ice_prognostic=comp_prognostic, ice_gnam=comp_gnam, & + ice_phase=comp_phase, ice_nx=comp_nx, ice_ny=comp_ny, & + histavg_ice=histavg_comp, ice_resume=comp_resume) + else if (component_firstletter == 'o') then + call seq_infodata_PutData(infodata, ocn_present=comp_present, & + ocn_prognostic=comp_prognostic, ocn_gnam=comp_gnam, & + ocn_phase=comp_phase, ocn_nx=comp_nx, ocn_ny=comp_ny, & + histavg_ocn=histavg_comp, ocn_resume=comp_resume) + else if (component_firstletter == 'r') then + call seq_infodata_PutData(infodata, rof_present=comp_present, & + rof_prognostic=comp_prognostic, rof_gnam=comp_gnam, & + rof_phase=comp_phase, rof_nx=comp_nx, rof_ny=comp_ny, & + histavg_rof=histavg_comp, rof_resume=comp_resume) + else if (component_firstletter == 'g') then + call seq_infodata_PutData(infodata, glc_present=comp_present, & + glc_prognostic=comp_prognostic, glc_gnam=comp_gnam, & + glc_phase=comp_phase, glc_nx=comp_nx, glc_ny=comp_ny, & + histavg_glc=histavg_comp, glc_resume=comp_resume) + else if (component_firstletter == 'w') then + call seq_infodata_PutData(infodata, wav_present=comp_present, & + wav_prognostic=comp_prognostic, wav_gnam=comp_gnam, & + wav_phase=comp_phase, wav_nx=comp_nx, wav_ny=comp_ny, & + histavg_wav=histavg_comp, wav_resume=comp_resume) + else if (component_firstletter == 'e') then + if ((loglevel > 1) .and. seq_comm_iamroot(1)) then + if (present(comp_gnam)) then + write(logunit,*) trim(subname),' Note: ESP type has no gnam property' + end if + if (present(comp_nx)) then + write(logunit,*) trim(subname),' Note: ESP type has no nx property' + end if + if (present(comp_ny)) then + write(logunit,*) trim(subname),' Note: ESP type has no ny property' + end if + if (present(histavg_comp)) then + write(logunit,*) trim(subname),' Note: ESP type has no histavg property' + end if + if (present(comp_resume)) then + write(logunit,*) trim(subname),' Note: ESP type has no resume property' + end if + + end if + + call seq_infodata_PutData(infodata, esp_present=comp_present, & + esp_prognostic=comp_prognostic, esp_phase=comp_phase) + else + call shr_sys_abort( subname//": unknown component-type first letter,'"//component_firstletter//"', aborting") + end if + +END SUBROUTINE seq_infodata_PutData_bytype +#endif +! ^ ifndef CPRPGI + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_pauseresume_bcast -- Broadcast pause/resume data from root pe +! +! !DESCRIPTION: +! +! Broadcast the pause_resume data from an infodata across pes +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_infodata_pauseresume_bcast(infodata, mpicom, pebcast) + + use shr_mpi_mod, only : shr_mpi_bcast + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! assume valid on root pe + integer(SHR_KIND_IN), intent(IN) :: mpicom ! MPI Communicator + integer(SHR_KIND_IN), optional, intent(IN) :: pebcast ! pe sending + +!EOP + + !----- local ----- + integer :: ind + integer(SHR_KIND_IN) :: pebcast_local + character(len=*), parameter :: subname = '(seq_infodata_pauseresume_bcast) ' + + if (present(pebcast)) then + pebcast_local = pebcast + else + pebcast_local = 0 + end if + + if (associated(infodata%pause_resume)) then + do ind = 1, num_inst_atm + call shr_mpi_bcast(infodata%pause_resume%atm_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_lnd + call shr_mpi_bcast(infodata%pause_resume%lnd_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_ice + call shr_mpi_bcast(infodata%pause_resume%ice_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_ocn + call shr_mpi_bcast(infodata%pause_resume%ocn_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_glc + call shr_mpi_bcast(infodata%pause_resume%glc_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_rof + call shr_mpi_bcast(infodata%pause_resume%rof_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + do ind = 1, num_inst_wav + call shr_mpi_bcast(infodata%pause_resume%wav_resume(ind), mpicom, & + pebcast=pebcast_local) + end do + call shr_mpi_bcast(infodata%pause_resume%cpl_resume, mpicom, & + pebcast=pebcast_local) + end if +end subroutine seq_infodata_pauseresume_bcast + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_bcast -- Broadcast an infodata from root pe +! +! !DESCRIPTION: +! +! Broadcast an infodata across pes +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_infodata_bcast(infodata,mpicom) + + use shr_mpi_mod, only : shr_mpi_bcast + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! assume valid on root pe + integer(SHR_KIND_IN), intent(IN) :: mpicom ! mpi comm + +!EOP + + !----- local ----- + integer :: ind + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call shr_mpi_bcast(infodata%cime_model, mpicom) + call shr_mpi_bcast(infodata%start_type, mpicom) + call shr_mpi_bcast(infodata%case_desc, mpicom) + call shr_mpi_bcast(infodata%model_version, mpicom) + call shr_mpi_bcast(infodata%username, mpicom) + call shr_mpi_bcast(infodata%hostname, mpicom) + call shr_mpi_bcast(infodata%case_name, mpicom) + call shr_mpi_bcast(infodata%timing_dir, mpicom) + call shr_mpi_bcast(infodata%tchkpt_dir, mpicom) + call shr_mpi_bcast(infodata%aqua_planet, mpicom) + call shr_mpi_bcast(infodata%aqua_planet_sst, mpicom) + call shr_mpi_bcast(infodata%run_barriers, mpicom) + call shr_mpi_bcast(infodata%brnch_retain_casename, mpicom) + call shr_mpi_bcast(infodata%read_restart, mpicom) + call shr_mpi_bcast(infodata%restart_pfile, mpicom) + call shr_mpi_bcast(infodata%restart_file, mpicom) + call shr_mpi_bcast(infodata%single_column, mpicom) + call shr_mpi_bcast(infodata%scmlat, mpicom) + call shr_mpi_bcast(infodata%scmlon, mpicom) + call shr_mpi_bcast(infodata%logFilePostFix, mpicom) + call shr_mpi_bcast(infodata%outPathRoot, mpicom) + call shr_mpi_bcast(infodata%perpetual, mpicom) + call shr_mpi_bcast(infodata%perpetual_ymd, mpicom) + call shr_mpi_bcast(infodata%orb_iyear, mpicom) + call shr_mpi_bcast(infodata%orb_iyear_align, mpicom) + call shr_mpi_bcast(infodata%orb_mode, mpicom) + call shr_mpi_bcast(infodata%orb_eccen, mpicom) + call shr_mpi_bcast(infodata%orb_obliq, mpicom) + call shr_mpi_bcast(infodata%orb_mvelp, mpicom) + call shr_mpi_bcast(infodata%orb_obliqr, mpicom) + call shr_mpi_bcast(infodata%orb_lambm0, mpicom) + call shr_mpi_bcast(infodata%orb_mvelpp, mpicom) + call shr_mpi_bcast(infodata%wv_sat_scheme, mpicom) + call shr_mpi_bcast(infodata%wv_sat_transition_start, mpicom) + call shr_mpi_bcast(infodata%wv_sat_use_tables, mpicom) + call shr_mpi_bcast(infodata%wv_sat_table_spacing, mpicom) + call shr_mpi_bcast(infodata%tfreeze_option, mpicom) + call shr_mpi_bcast(infodata%flux_epbal, mpicom) + call shr_mpi_bcast(infodata%flux_albav, mpicom) + call shr_mpi_bcast(infodata%flux_diurnal, mpicom) + call shr_mpi_bcast(infodata%gust_fac, mpicom) + call shr_mpi_bcast(infodata%glc_renormalize_smb, mpicom) + call shr_mpi_bcast(infodata%wall_time_limit, mpicom) + call shr_mpi_bcast(infodata%force_stop_at, mpicom) + call shr_mpi_bcast(infodata%atm_gnam, mpicom) + call shr_mpi_bcast(infodata%lnd_gnam, mpicom) + call shr_mpi_bcast(infodata%ocn_gnam, mpicom) + call shr_mpi_bcast(infodata%ice_gnam, mpicom) + call shr_mpi_bcast(infodata%rof_gnam, mpicom) + call shr_mpi_bcast(infodata%glc_gnam, mpicom) + call shr_mpi_bcast(infodata%wav_gnam, mpicom) + call shr_mpi_bcast(infodata%shr_map_dopole, mpicom) + call shr_mpi_bcast(infodata%vect_map, mpicom) + call shr_mpi_bcast(infodata%aoflux_grid, mpicom) + call shr_mpi_bcast(infodata%cpl_decomp, mpicom) + call shr_mpi_bcast(infodata%cpl_seq_option, mpicom) + call shr_mpi_bcast(infodata%do_budgets, mpicom) + call shr_mpi_bcast(infodata%do_histinit, mpicom) + call shr_mpi_bcast(infodata%budget_inst, mpicom) + call shr_mpi_bcast(infodata%budget_daily, mpicom) + call shr_mpi_bcast(infodata%budget_month, mpicom) + call shr_mpi_bcast(infodata%budget_ann, mpicom) + call shr_mpi_bcast(infodata%budget_ltann, mpicom) + call shr_mpi_bcast(infodata%budget_ltend, mpicom) + call shr_mpi_bcast(infodata%histaux_a2x , mpicom) + call shr_mpi_bcast(infodata%histaux_a2x1hri , mpicom) + call shr_mpi_bcast(infodata%histaux_a2x1hr , mpicom) + call shr_mpi_bcast(infodata%histaux_a2x3hr , mpicom) + call shr_mpi_bcast(infodata%histaux_a2x3hrp , mpicom) + call shr_mpi_bcast(infodata%histaux_a2x24hr , mpicom) + call shr_mpi_bcast(infodata%histaux_l2x1yr , mpicom) + call shr_mpi_bcast(infodata%histaux_l2x , mpicom) + call shr_mpi_bcast(infodata%histaux_r2x , mpicom) + call shr_mpi_bcast(infodata%histavg_atm , mpicom) + call shr_mpi_bcast(infodata%histavg_lnd , mpicom) + call shr_mpi_bcast(infodata%histavg_ocn , mpicom) + call shr_mpi_bcast(infodata%histavg_ice , mpicom) + call shr_mpi_bcast(infodata%histavg_rof , mpicom) + call shr_mpi_bcast(infodata%histavg_glc , mpicom) + call shr_mpi_bcast(infodata%histavg_wav , mpicom) + call shr_mpi_bcast(infodata%histavg_xao , mpicom) + call shr_mpi_bcast(infodata%drv_threading, mpicom) + call shr_mpi_bcast(infodata%eps_frac, mpicom) + call shr_mpi_bcast(infodata%eps_amask, mpicom) + call shr_mpi_bcast(infodata%eps_agrid, mpicom) + call shr_mpi_bcast(infodata%eps_aarea, mpicom) + call shr_mpi_bcast(infodata%eps_omask, mpicom) + call shr_mpi_bcast(infodata%eps_ogrid, mpicom) + call shr_mpi_bcast(infodata%eps_oarea, mpicom) + call shr_mpi_bcast(infodata%reprosum_use_ddpdd, mpicom) + call shr_mpi_bcast(infodata%reprosum_diffmax, mpicom) + call shr_mpi_bcast(infodata%reprosum_recompute, mpicom) + call shr_mpi_bcast(infodata%mct_usealltoall, mpicom) + call shr_mpi_bcast(infodata%mct_usevector, mpicom) + + call shr_mpi_bcast(infodata%info_debug, mpicom) + call shr_mpi_bcast(infodata%bfbflag, mpicom) + call shr_mpi_bcast(infodata%esmf_map_flag, mpicom) + call shr_mpi_bcast(infodata%dead_comps, mpicom) + + call shr_mpi_bcast(infodata%atm_present, mpicom) + call shr_mpi_bcast(infodata%atm_prognostic, mpicom) + call shr_mpi_bcast(infodata%lnd_present, mpicom) + call shr_mpi_bcast(infodata%lnd_prognostic, mpicom) + call shr_mpi_bcast(infodata%rof_present, mpicom) + call shr_mpi_bcast(infodata%rofice_present, mpicom) + call shr_mpi_bcast(infodata%rof_prognostic, mpicom) + call shr_mpi_bcast(infodata%flood_present, mpicom) + call shr_mpi_bcast(infodata%ocn_present, mpicom) + call shr_mpi_bcast(infodata%ocn_prognostic, mpicom) + call shr_mpi_bcast(infodata%ocnrof_prognostic, mpicom) + call shr_mpi_bcast(infodata%ice_present, mpicom) + call shr_mpi_bcast(infodata%ice_prognostic, mpicom) + call shr_mpi_bcast(infodata%iceberg_prognostic, mpicom) + call shr_mpi_bcast(infodata%glc_present, mpicom) + call shr_mpi_bcast(infodata%glclnd_present, mpicom) + call shr_mpi_bcast(infodata%glcocn_present, mpicom) + call shr_mpi_bcast(infodata%glcice_present, mpicom) + call shr_mpi_bcast(infodata%glc_prognostic, mpicom) + call shr_mpi_bcast(infodata%glc_coupled_fluxes, mpicom) + call shr_mpi_bcast(infodata%wav_present, mpicom) + call shr_mpi_bcast(infodata%wav_prognostic, mpicom) + call shr_mpi_bcast(infodata%esp_present, mpicom) + call shr_mpi_bcast(infodata%esp_prognostic, mpicom) + + call shr_mpi_bcast(infodata%atm_nx, mpicom) + call shr_mpi_bcast(infodata%atm_ny, mpicom) + call shr_mpi_bcast(infodata%lnd_nx, mpicom) + call shr_mpi_bcast(infodata%lnd_ny, mpicom) + call shr_mpi_bcast(infodata%rof_nx, mpicom) + call shr_mpi_bcast(infodata%rof_ny, mpicom) + call shr_mpi_bcast(infodata%ice_nx, mpicom) + call shr_mpi_bcast(infodata%ice_ny, mpicom) + call shr_mpi_bcast(infodata%ocn_nx, mpicom) + call shr_mpi_bcast(infodata%ocn_ny, mpicom) + call shr_mpi_bcast(infodata%glc_nx, mpicom) + call shr_mpi_bcast(infodata%glc_ny, mpicom) + call shr_mpi_bcast(infodata%wav_nx, mpicom) + call shr_mpi_bcast(infodata%wav_ny, mpicom) + + call shr_mpi_bcast(infodata%nextsw_cday, mpicom) + call shr_mpi_bcast(infodata%precip_fact, mpicom) + call shr_mpi_bcast(infodata%atm_phase, mpicom) + call shr_mpi_bcast(infodata%lnd_phase, mpicom) + call shr_mpi_bcast(infodata%ice_phase, mpicom) + call shr_mpi_bcast(infodata%ocn_phase, mpicom) + call shr_mpi_bcast(infodata%glc_phase, mpicom) + call shr_mpi_bcast(infodata%rof_phase, mpicom) + call shr_mpi_bcast(infodata%wav_phase, mpicom) + call shr_mpi_bcast(infodata%atm_aero, mpicom) + call shr_mpi_bcast(infodata%glc_g2lupdate, mpicom) + call shr_mpi_bcast(infodata%glc_valid_input, mpicom) + + call seq_infodata_pauseresume_bcast(infodata, mpicom) + +end subroutine seq_infodata_bcast + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_Exchange -- Broadcast a subset of infodata between pes +! +! !DESCRIPTION: +! +! Broadcast a subset of infodata data between pes to support "exchange" of information +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_infodata_Exchange(infodata,ID,type) + + use shr_mpi_mod, only : shr_mpi_bcast + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! assume valid on root pe + integer(SHR_KIND_IN), intent(IN) :: ID ! mpi comm + character(len=*), intent(IN) :: type ! type + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: mpicom ! mpicom + integer(SHR_KIND_IN) :: cmppe ! component 'root' for broadcast + integer(SHR_KIND_IN) :: cplpe ! coupler 'root' for broadcast + logical :: atm2cpli,atm2cplr + logical :: lnd2cpli,lnd2cplr + logical :: rof2cpli,rof2cplr + logical :: ocn2cpli,ocn2cplr + logical :: ice2cpli,ice2cplr + logical :: glc2cpli,glc2cplr + logical :: wav2cpli,wav2cplr + logical :: esp2cpli,esp2cplr + logical :: cpl2i,cpl2r + logical :: logset + logical :: deads ! local variable to hold info temporarily + character(len=*), parameter :: subname = '(seq_infodata_Exchange) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call seq_comm_setptrs(ID, mpicom=mpicom, cmppe=cmppe, cplpe=cplpe) + + logset = .false. + + atm2cpli = .false. + atm2cplr = .false. + lnd2cpli = .false. + lnd2cplr = .false. + rof2cpli = .false. + rof2cplr = .false. + ocn2cpli = .false. + ocn2cplr = .false. + ice2cpli = .false. + ice2cplr = .false. + glc2cpli = .false. + glc2cplr = .false. + wav2cpli = .false. + wav2cplr = .false. + esp2cpli = .false. + esp2cplr = .false. + cpl2i = .false. + cpl2r = .false. + + ! --- translate type into logicals --- + + if (trim(type) == 'atm2cpl_init') then + atm2cpli = .true. + atm2cplr = .true. + logset = .true. + endif + if (trim(type) == 'atm2cpl_run') then + atm2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'lnd2cpl_init') then + lnd2cpli = .true. + lnd2cplr = .true. + logset = .true. + endif + if (trim(type) == 'lnd2cpl_run') then + lnd2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'rof2cpl_init') then + rof2cpli = .true. + rof2cplr = .true. + logset = .true. + endif + if (trim(type) == 'rof2cpl_run') then + rof2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'ocn2cpl_init') then + ocn2cpli = .true. + ocn2cplr = .true. + logset = .true. + endif + if (trim(type) == 'ocn2cpl_run') then + ocn2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'ice2cpl_init') then + ice2cpli = .true. + ice2cplr = .true. + logset = .true. + endif + if (trim(type) == 'ice2cpl_run') then + ice2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'glc2cpl_init') then + glc2cpli = .true. + glc2cplr = .true. + logset = .true. + endif + if (trim(type) == 'glc2cpl_run') then + glc2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'wav2cpl_init') then + wav2cpli = .true. + wav2cplr = .true. + logset = .true. + endif + if (trim(type) == 'wav2cpl_run') then + wav2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'esp2cpl_init') then + esp2cpli = .true. + esp2cplr = .true. + logset = .true. + endif + if (trim(type) == 'esp2cpl_run') then + esp2cplr = .true. + logset = .true. + endif + + if (trim(type) == 'cpl2atm_init' .or. & + trim(type) == 'cpl2lnd_init' .or. & + trim(type) == 'cpl2rof_init' .or. & + trim(type) == 'cpl2ocn_init' .or. & + trim(type) == 'cpl2glc_init' .or. & + trim(type) == 'cpl2wav_init' .or. & + trim(type) == 'cpl2esp_init' .or. & + trim(type) == 'cpl2ice_init') then + cpl2i = .true. + cpl2r = .true. + logset = .true. + endif + + if (trim(type) == 'cpl2atm_run' .or. & + trim(type) == 'cpl2lnd_run' .or. & + trim(type) == 'cpl2rof_run' .or. & + trim(type) == 'cpl2ocn_run' .or. & + trim(type) == 'cpl2glc_run' .or. & + trim(type) == 'cpl2wav_run' .or. & + trim(type) == 'cpl2ice_run') then + cpl2r = .true. + logset = .true. + endif + + ! --- make sure the type was valid --- + + if (.not. logset) then + write(logunit,*) trim(subname),' ERROR: type invalid ',trim(type) + call shr_sys_abort() + endif + + ! --- now execute exchange --- + + if (atm2cpli) then + call shr_mpi_bcast(infodata%atm_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%atm_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%atm_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%atm_ny, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%atm_aero, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (lnd2cpli) then + call shr_mpi_bcast(infodata%lnd_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%lnd_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%lnd_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%lnd_ny, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (rof2cpli) then + call shr_mpi_bcast(infodata%rof_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%rofice_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%rof_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%rof_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%rof_ny, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%flood_present, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (ocn2cpli) then + call shr_mpi_bcast(infodata%ocn_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ocn_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ocnrof_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ocn_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ocn_ny, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (ice2cpli) then + call shr_mpi_bcast(infodata%ice_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ice_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%iceberg_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ice_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%ice_ny, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (glc2cpli) then + call shr_mpi_bcast(infodata%glc_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glclnd_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glcocn_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glcice_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glc_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glc_coupled_fluxes, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glc_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%glc_ny, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (wav2cpli) then + call shr_mpi_bcast(infodata%wav_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%wav_prognostic, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%wav_nx, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%wav_ny, mpicom, pebcast=cmppe) + ! dead_comps is true if it's ever set to true + deads = infodata%dead_comps + call shr_mpi_bcast(deads, mpicom, pebcast=cmppe) + if (deads .or. infodata%dead_comps) infodata%dead_comps = .true. + endif + + if (esp2cpli) then + call shr_mpi_bcast(infodata%esp_present, mpicom, pebcast=cmppe) + call shr_mpi_bcast(infodata%esp_prognostic, mpicom, pebcast=cmppe) + call seq_infodata_pauseresume_bcast(infodata, mpicom, pebcast=cmppe) + endif + + if (cpl2i) then + call shr_mpi_bcast(infodata%atm_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%atm_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%lnd_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%lnd_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%rof_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%rofice_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%rof_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%flood_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%ocn_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%ocn_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%ocnrof_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%ice_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%ice_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%iceberg_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glc_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glclnd_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glcocn_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glcice_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glc_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glc_coupled_fluxes, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%wav_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%wav_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%esp_present, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%esp_prognostic, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%dead_comps, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%atm_aero, mpicom, pebcast=cplpe) + endif + + ! Run-time data exchanges + if (atm2cplr) then + call shr_mpi_bcast(infodata%nextsw_cday, mpicom, pebcast=cmppe) + endif + + if (ocn2cplr) then + call shr_mpi_bcast(infodata%precip_fact, mpicom, pebcast=cmppe) + endif + + if (esp2cplr) then + call seq_infodata_pauseresume_bcast(infodata, mpicom, pebcast=cmppe) + endif + + if (cpl2r) then + call shr_mpi_bcast(infodata%nextsw_cday, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%precip_fact, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glc_g2lupdate, mpicom, pebcast=cplpe) + call shr_mpi_bcast(infodata%glc_valid_input, mpicom, pebcast=cplpe) + call seq_infodata_pauseresume_bcast(infodata, mpicom, pebcast=cplpe) + endif + +end subroutine seq_infodata_Exchange + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: seq_infodata_Check -- Check that input InputInfo derived type is valid +! +! !DESCRIPTION: +! +! Check that input infodata object has reasonable values +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_infodata_Check( infodata ) + +! !USES: + + use shr_assert_mod, only: shr_assert_in_domain + use shr_string_mod, only: shr_string_listIntersect + use shr_wv_sat_mod, only: shr_wv_sat_get_scheme_idx, shr_wv_sat_valid_idx + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(INOUT) :: infodata ! Output CCSM structure + +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_infodata_Check) ' + integer :: lastchar ! Last character index + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + ! --- CIME model ------ + if ( trim(infodata%cime_model) /= 'acme' .and. trim(infodata%cime_model) /= 'cesm') then + call shr_sys_abort( subname//': cime_model must be set to acme or cesm, aborting') + end if + + ! --- Case name ------ + lastchar = len(infodata%case_name) + if ( len_trim(infodata%case_name) == 0) then + call shr_sys_abort( subname//': variable case_name must be set, aborting') + end if + if (infodata%case_name(lastchar:lastchar) /= ' ') then + write(logunit,"(A,I4,A)")'ERROR: case_name must not exceed ', len(infodata%case_name)-1, & + ' characters' + call shr_sys_abort( subname//': variable case_name must be set, aborting') + end if + + ! --- Restart pointer file ----- + if ( len_trim(infodata%restart_pfile) == 0 ) then + call shr_sys_abort( subname//': restart_pfile must be set' ) + end if + + ! --- LogFile ending name ----- + if ( len_trim(infodata%logFilePostFix) == 0 ) then + call shr_sys_abort( subname//': logFilePostFix must be set to something not blank' ) + end if + + ! --- Output path root directory ----- + if ( len_trim(infodata%outPathRoot) == 0 ) then + call shr_sys_abort( subname//': outPathRoot must be set' ) + end if + if ( index(infodata%outPathRoot,"/",back=.true.) /= & + len_trim(infodata%outPathRoot) ) then + call shr_sys_abort( subname//': outPathRoot must end with a slash' ) + end if + + ! --- Start-type ------ + if ((trim(infodata%start_type) /= seq_infodata_start_type_start) .and. & + (trim(infodata%start_type) /= seq_infodata_start_type_cont ) .and. & + (trim(infodata%start_type) /= seq_infodata_start_type_brnch)) then + call shr_sys_abort(subname//': start_type invalid = '//trim(infodata%start_type)) + end if + + if ((trim(infodata%start_type) == seq_infodata_start_type_cont ) .and. & + (trim(infodata%case_name) /= trim(infodata%rest_case_name))) then + write(logunit,'(10a)') subname,' case_name =',trim(infodata%case_name),':', & + ' rest_case_name =',trim(infodata%rest_case_name),':' + call shr_sys_abort(subname//': invalid continue restart case name = '//trim(infodata%rest_case_name)) + endif + + if (infodata%orb_eccen == SHR_ORB_UNDEF_REAL .or. & + infodata%orb_obliqr == SHR_ORB_UNDEF_REAL .or. & + infodata%orb_mvelpp == SHR_ORB_UNDEF_REAL .or. & + infodata%orb_lambm0 == SHR_ORB_UNDEF_REAL) then + call shr_sys_abort(subname//': orb params incorrect') + endif + + if (.not. shr_wv_sat_valid_idx(shr_wv_sat_get_scheme_idx(trim(infodata%wv_sat_scheme)))) then + call shr_sys_abort(subname//': "'//trim(infodata%wv_sat_scheme)//'" & + &is not a recognized saturation vapor pressure scheme name') + end if + + ! A transition range averaging method in CAM is only valid for: + ! + ! -40 deg C <= T <= 0 deg C + ! + ! shr_wv_sat_mod itself checks for values with the wrong sign, but we + ! have to check that the range is no more than 40 deg C here. Even + ! though this is a CAM-specific restriction, it's not really likely + ! that any other parameterization will be dealing with mixed-phase + ! water below 40 deg C anyway. + call shr_assert_in_domain(infodata%wv_sat_transition_start, & + ge=0._SHR_KIND_R8, le=40._SHR_KIND_R8, & + varname="wv_sat_transition_start",& + msg="Invalid transition temperature range.") + + if ((trim(infodata%aoflux_grid) /= 'ocn') .and. & + (trim(infodata%aoflux_grid) /= 'atm') .and. & + (trim(infodata%aoflux_grid) /= 'exch')) then + write(logunit,'(2a)') 'ERROR aoflux_grid not supported = ',trim(infodata%aoflux_grid) + call shr_sys_abort(subname//': aoflux_grid invalid = '//trim(infodata%aoflux_grid)) + endif + + if ((trim(infodata%vect_map) /= 'none') .and. & + (trim(infodata%vect_map) /= 'cart3d') .and. & + (trim(infodata%vect_map) /= 'cart3d_diag') .and. & + (trim(infodata%vect_map) /= 'cart3d_uvw') .and. & + (trim(infodata%vect_map) /= 'cart3d_uvw_diag')) then + write(logunit,'(2a)') 'ERROR vect_map not supported = ',trim(infodata%vect_map) + call shr_sys_abort(subname//': vect_map invalid = '//trim(infodata%vect_map)) + endif + +END SUBROUTINE seq_infodata_Check + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_infodata_print -- Print out values to log file +! +! !DESCRIPTION: +! +! Print derivied type out to screen. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE seq_infodata_print( infodata ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_infodata_type), intent(IN) :: infodata ! Output CCSM structure + +!EOP + + !----- local ----- + integer :: ind + character(len=*), parameter :: subname = '(seq_infodata_print) ' + character(len=*), parameter :: F0A = "(2A,A)" + character(len=*), parameter :: F0L = "(2A,L3)" + character(len=*), parameter :: F0I = "(2A,I10)" + character(len=*), parameter :: FIA = "(2A,I5,2A)" + character(len=*), parameter :: F0S = "(2A,I4)" + character(len=*), parameter :: F0R = "(2A,g22.14)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + +! if (loglevel > 0) then + write(logunit,F0A) subname,'CIME model = ', trim(infodata%cime_model) + write(logunit,F0A) subname,'Start type = ', trim(infodata%start_type) + write(logunit,F0A) subname,'Case name = ', trim(infodata%case_name) + write(logunit,F0A) subname,'Case description = ', trim(infodata%case_desc) + write(logunit,F0A) subname,'Model version = ', trim(infodata%model_version) + write(logunit,F0A) subname,'Username = ', trim(infodata%username) + write(logunit,F0A) subname,'Hostname = ', trim(infodata%hostname) + write(logunit,F0A) subname,'Timing Dir = ', trim(infodata%timing_dir) + write(logunit,F0A) subname,'Timing Checkpoint Dir = ', trim(infodata%tchkpt_dir) + write(logunit,F0A) subname,'Restart case name = ', trim(infodata%rest_case_name) + + write(logunit,F0L) subname,'aqua_planet mode = ', infodata%aqua_planet + write(logunit,F0I) subname,'aqua_planet analytic sst = ', infodata%aqua_planet_sst + write(logunit,F0L) subname,'brnch_retain_casename = ', infodata%brnch_retain_casename + + write(logunit,F0L) subname,'read_restart flag = ', infodata%read_restart + write(logunit,F0A) subname,'Restart pointer file = ', trim(infodata%restart_pfile) + write(logunit,F0A) subname,'Restart file (full path) = ', trim(infodata%restart_file) + + write(logunit,F0L) subname,'single_column = ', infodata%single_column + write(logunit,F0R) subname,'scmlat = ', infodata%scmlat + write(logunit,F0R) subname,'scmlon = ', infodata%scmlon + + write(logunit,F0A) subname,'Log output end name = ', trim(infodata%logFilePostFix) + write(logunit,F0A) subname,'Output path dir = ', trim(infodata%outPathRoot) + + write(logunit,F0L) subname,'perpetual = ', infodata%perpetual + write(logunit,F0I) subname,'perpetual_ymd = ', infodata%perpetual_ymd + + write(logunit,F0A) subname,'orb_mode = ', trim(infodata%orb_mode) + if (trim(infodata%orb_mode) == trim(seq_infodata_orb_fixed_parameters)) then + write(logunit,F0R) subname,'orb_eccen = ', infodata%orb_eccen + write(logunit,F0R) subname,'orb_obliq = ', infodata%orb_obliq + write(logunit,F0R) subname,'orb_mvelp = ', infodata%orb_mvelp + write(logunit,F0R) subname,'orb_obliqr = ', infodata%orb_obliqr + write(logunit,F0R) subname,'orb_mvelpp = ', infodata%orb_mvelpp + write(logunit,F0R) subname,'orb_lambm0 = ', infodata%orb_lambm0 + elseif (trim(infodata%orb_mode) == trim(seq_infodata_orb_fixed_year)) then + write(logunit,F0I) subname,'orb_iyear = ', infodata%orb_iyear + write(logunit,F0R) subname,'orb_eccen = ', infodata%orb_eccen + write(logunit,F0R) subname,'orb_obliq = ', infodata%orb_obliq + write(logunit,F0R) subname,'orb_mvelp = ', infodata%orb_mvelp + write(logunit,F0R) subname,'orb_obliqr = ', infodata%orb_obliqr + write(logunit,F0R) subname,'orb_mvelpp = ', infodata%orb_mvelpp + write(logunit,F0R) subname,'orb_lambm0 = ', infodata%orb_lambm0 + elseif (trim(infodata%orb_mode) == trim(seq_infodata_orb_variable_year)) then + write(logunit,F0I) subname,'orb_iyear = ', infodata%orb_iyear + write(logunit,F0I) subname,'orb_iyear_align = ', infodata%orb_iyear_align + endif + + write(logunit,F0A) subname,'wv_sat_scheme = ', trim(infodata%wv_sat_scheme) + write(logunit,F0R) subname,'wv_sat_transition_start = ', infodata%wv_sat_transition_start + write(logunit,F0L) subname,'wv_sat_use_tables = ', infodata%wv_sat_use_tables + write(logunit,F0R) subname,'wv_sat_table_spacing = ', infodata%wv_sat_table_spacing + + write(logunit,F0A) subname,'tfreeze_option = ', trim(infodata%tfreeze_option) + write(logunit,F0A) subname,'flux_epbal = ', trim(infodata%flux_epbal) + write(logunit,F0L) subname,'flux_albav = ', infodata%flux_albav + write(logunit,F0L) subname,'flux_diurnal = ', infodata%flux_diurnal + write(logunit,F0R) subname,'gust_fac = ', infodata%gust_fac + write(logunit,F0A) subname,'glc_renormalize_smb = ', trim(infodata%glc_renormalize_smb) + write(logunit,F0R) subname,'wall_time_limit = ', infodata%wall_time_limit + write(logunit,F0A) subname,'force_stop_at = ', trim(infodata%force_stop_at) + write(logunit,F0A) subname,'atm_gridname = ', trim(infodata%atm_gnam) + write(logunit,F0A) subname,'lnd_gridname = ', trim(infodata%lnd_gnam) + write(logunit,F0A) subname,'ocn_gridname = ', trim(infodata%ocn_gnam) + write(logunit,F0A) subname,'ice_gridname = ', trim(infodata%ice_gnam) + write(logunit,F0A) subname,'rof_gridname = ', trim(infodata%rof_gnam) + write(logunit,F0A) subname,'glc_gridname = ', trim(infodata%glc_gnam) + write(logunit,F0A) subname,'wav_gridname = ', trim(infodata%wav_gnam) + write(logunit,F0L) subname,'shr_map_dopole = ', infodata%shr_map_dopole + write(logunit,F0A) subname,'vect_map = ', trim(infodata%vect_map) + write(logunit,F0A) subname,'aoflux_grid = ', trim(infodata%aoflux_grid) + write(logunit,F0A) subname,'cpl_seq_option = ', trim(infodata%cpl_seq_option) + write(logunit,F0S) subname,'cpl_decomp = ', infodata%cpl_decomp + write(logunit,F0L) subname,'do_budgets = ', infodata%do_budgets + write(logunit,F0L) subname,'do_histinit = ', infodata%do_histinit + write(logunit,F0S) subname,'budget_inst = ', infodata%budget_inst + write(logunit,F0S) subname,'budget_daily = ', infodata%budget_daily + write(logunit,F0S) subname,'budget_month = ', infodata%budget_month + write(logunit,F0S) subname,'budget_ann = ', infodata%budget_ann + write(logunit,F0S) subname,'budget_ltann = ', infodata%budget_ltann + write(logunit,F0S) subname,'budget_ltend = ', infodata%budget_ltend + write(logunit,F0L) subname,'histaux_a2x = ', infodata%histaux_a2x + write(logunit,F0L) subname,'histaux_a2x1hri = ', infodata%histaux_a2x1hri + write(logunit,F0L) subname,'histaux_a2x1hr = ', infodata%histaux_a2x1hr + write(logunit,F0L) subname,'histaux_a2x3hr = ', infodata%histaux_a2x3hr + write(logunit,F0L) subname,'histaux_a2x3hrp = ', infodata%histaux_a2x3hrp + write(logunit,F0L) subname,'histaux_a2x24hr = ', infodata%histaux_a2x24hr + write(logunit,F0L) subname,'histaux_l2x1yr = ', infodata%histaux_l2x1yr + write(logunit,F0L) subname,'histaux_l2x = ', infodata%histaux_l2x + write(logunit,F0L) subname,'histaux_r2x = ', infodata%histaux_r2x + write(logunit,F0L) subname,'histavg_atm = ', infodata%histavg_atm + write(logunit,F0L) subname,'histavg_lnd = ', infodata%histavg_lnd + write(logunit,F0L) subname,'histavg_ocn = ', infodata%histavg_ocn + write(logunit,F0L) subname,'histavg_ice = ', infodata%histavg_ice + write(logunit,F0L) subname,'histavg_rof = ', infodata%histavg_rof + write(logunit,F0L) subname,'histavg_glc = ', infodata%histavg_glc + write(logunit,F0L) subname,'histavg_wav = ', infodata%histavg_wav + write(logunit,F0L) subname,'histavg_xao = ', infodata%histavg_xao + write(logunit,F0L) subname,'drv_threading = ', infodata%drv_threading + + write(logunit,F0R) subname,'eps_frac = ', infodata%eps_frac + write(logunit,F0R) subname,'eps_amask = ', infodata%eps_amask + write(logunit,F0R) subname,'eps_agrid = ', infodata%eps_agrid + write(logunit,F0R) subname,'eps_aarea = ', infodata%eps_aarea + write(logunit,F0R) subname,'eps_omask = ', infodata%eps_omask + write(logunit,F0R) subname,'eps_ogrid = ', infodata%eps_ogrid + write(logunit,F0R) subname,'eps_oarea = ', infodata%eps_oarea + + write(logunit,F0L) subname,'reprosum_use_ddpdd = ', infodata%reprosum_use_ddpdd + write(logunit,F0R) subname,'reprosum_diffmax = ', infodata%reprosum_diffmax + write(logunit,F0L) subname,'reprosum_recompute = ', infodata%reprosum_recompute + + write(logunit,F0L) subname,'mct_usealltoall = ', infodata%mct_usealltoall + write(logunit,F0L) subname,'mct_usevector = ', infodata%mct_usevector + + write(logunit,F0S) subname,'info_debug = ', infodata%info_debug + write(logunit,F0L) subname,'bfbflag = ', infodata%bfbflag + write(logunit,F0L) subname,'esmf_map_flag = ', infodata%esmf_map_flag + write(logunit,F0L) subname,'dead_comps = ', infodata%dead_comps + write(logunit,F0L) subname,'run_barriers = ', infodata%run_barriers + + write(logunit,F0L) subname,'atm_present = ', infodata%atm_present + write(logunit,F0L) subname,'atm_prognostic = ', infodata%atm_prognostic + write(logunit,F0L) subname,'lnd_present = ', infodata%lnd_present + write(logunit,F0L) subname,'lnd_prognostic = ', infodata%lnd_prognostic + write(logunit,F0L) subname,'rof_present = ', infodata%rof_present + write(logunit,F0L) subname,'rofice_present = ', infodata%rofice_present + write(logunit,F0L) subname,'rof_prognostic = ', infodata%rof_prognostic + write(logunit,F0L) subname,'flood_present = ', infodata%flood_present + write(logunit,F0L) subname,'ocn_present = ', infodata%ocn_present + write(logunit,F0L) subname,'ocn_prognostic = ', infodata%ocn_prognostic + write(logunit,F0L) subname,'ocnrof_prognostic = ', infodata%ocnrof_prognostic + write(logunit,F0L) subname,'ice_present = ', infodata%ice_present + write(logunit,F0L) subname,'ice_prognostic = ', infodata%ice_prognostic + write(logunit,F0L) subname,'iceberg_prognostic = ', infodata%iceberg_prognostic + write(logunit,F0L) subname,'glc_present = ', infodata%glc_present + write(logunit,F0L) subname,'glclnd_present = ', infodata%glclnd_present + write(logunit,F0L) subname,'glcocn_present = ', infodata%glcocn_present + write(logunit,F0L) subname,'glcice_present = ', infodata%glcice_present + write(logunit,F0L) subname,'glc_prognostic = ', infodata%glc_prognostic + write(logunit,F0L) subname,'glc_coupled_fluxes = ', infodata%glc_coupled_fluxes + write(logunit,F0L) subname,'wav_present = ', infodata%wav_present + write(logunit,F0L) subname,'wav_prognostic = ', infodata%wav_prognostic + write(logunit,F0L) subname,'esp_present = ', infodata%esp_present + write(logunit,F0L) subname,'esp_prognostic = ', infodata%esp_prognostic + + write(logunit,F0I) subname,'atm_nx = ', infodata%atm_nx + write(logunit,F0I) subname,'atm_ny = ', infodata%atm_ny + write(logunit,F0I) subname,'lnd_nx = ', infodata%lnd_nx + write(logunit,F0I) subname,'lnd_ny = ', infodata%lnd_ny + write(logunit,F0I) subname,'rof_nx = ', infodata%rof_nx + write(logunit,F0I) subname,'rof_ny = ', infodata%rof_ny + write(logunit,F0I) subname,'ice_nx = ', infodata%ice_nx + write(logunit,F0I) subname,'ice_ny = ', infodata%ice_ny + write(logunit,F0I) subname,'ocn_nx = ', infodata%ocn_nx + write(logunit,F0I) subname,'ocn_ny = ', infodata%ocn_ny + write(logunit,F0I) subname,'glc_nx = ', infodata%glc_nx + write(logunit,F0I) subname,'glc_ny = ', infodata%glc_ny + write(logunit,F0I) subname,'wav_nx = ', infodata%wav_nx + write(logunit,F0I) subname,'wav_ny = ', infodata%wav_ny + + write(logunit,F0R) subname,'nextsw_cday = ', infodata%nextsw_cday + write(logunit,F0R) subname,'precip_fact = ', infodata%precip_fact + write(logunit,F0L) subname,'atm_aero = ', infodata%atm_aero + + write(logunit,F0S) subname,'atm_phase = ', infodata%atm_phase + write(logunit,F0S) subname,'lnd_phase = ', infodata%lnd_phase + write(logunit,F0S) subname,'ocn_phase = ', infodata%ocn_phase + write(logunit,F0S) subname,'ice_phase = ', infodata%ice_phase + write(logunit,F0S) subname,'glc_phase = ', infodata%glc_phase + write(logunit,F0S) subname,'rof_phase = ', infodata%rof_phase + write(logunit,F0S) subname,'wav_phase = ', infodata%wav_phase + + write(logunit,F0L) subname,'glc_g2lupdate = ', infodata%glc_g2lupdate + if (associated(infodata%pause_resume)) then + do ind = 1, num_inst_atm + if (len_trim(infodata%pause_resume%atm_resume(ind)) > 0) then + write(logunit,FIA) subname,'atm_resume(',ind,') = ', trim(infodata%pause_resume%atm_resume(ind)) + end if + end do + do ind = 1, num_inst_lnd + if (len_trim(infodata%pause_resume%lnd_resume(ind)) > 0) then + write(logunit,FIA) subname,'lnd_resume(',ind,') = ', trim(infodata%pause_resume%lnd_resume(ind)) + end if + end do + do ind = 1, num_inst_ocn + if (len_trim(infodata%pause_resume%ocn_resume(ind)) > 0) then + write(logunit,FIA) subname,'ocn_resume(',ind,') = ', trim(infodata%pause_resume%ocn_resume(ind)) + end if + end do + do ind = 1, num_inst_ice + if (len_trim(infodata%pause_resume%ice_resume(ind)) > 0) then + write(logunit,FIA) subname,'ice_resume(',ind,') = ', trim(infodata%pause_resume%ice_resume(ind)) + end if + end do + do ind = 1, num_inst_glc + if (len_trim(infodata%pause_resume%glc_resume(ind)) > 0) then + write(logunit,FIA) subname,'glc_resume(',ind,') = ', trim(infodata%pause_resume%glc_resume(ind)) + end if + end do + do ind = 1, num_inst_rof + if (len_trim(infodata%pause_resume%rof_resume(ind)) > 0) then + write(logunit,FIA) subname,'rof_resume(',ind,') = ', trim(infodata%pause_resume%rof_resume(ind)) + end if + end do + do ind = 1, num_inst_wav + if (len_trim(infodata%pause_resume%wav_resume(ind)) > 0) then + write(logunit,FIA) subname,'wav_resume(',ind,') = ', trim(infodata%pause_resume%wav_resume(ind)) + end if + end do + if (len_trim(infodata%pause_resume%cpl_resume) > 0) then + write(logunit,F0A) subname,'cpl_resume = ', trim(infodata%pause_resume%cpl_resume) + end if + end if +! endif + +END SUBROUTINE seq_infodata_print + +!=============================================================================== +!=============================================================================== + +END MODULE seq_infodata_mod diff --git a/driver-mct/shr/seq_io_read_mod.F90 b/driver-mct/shr/seq_io_read_mod.F90 new file mode 100644 index 000000000000..3e13996c3e10 --- /dev/null +++ b/driver-mct/shr/seq_io_read_mod.F90 @@ -0,0 +1,332 @@ +!=============================================================================== +! SVN $Id: seq_io_mod.F90 50621 2013-08-30 02:53:41Z mvertens $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/drv/seq_mct/branches/comptype/shr/seq_io_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: seq_io_read_mod -- reads integer, real arrays and chacter of driver files +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2007-Oct-26 - T. Craig first version +! 2007-Dec-06 - T. Craig update and improve +! 2008-Feb-16 - J. Edwards convert to PIO +! 2010-Nov - J. Edwards move PIO init and namelists from components to driver +! Current Problems +! - the original use of seq_io will now ONLY work with the cpl because +! of hardwiring cpl_io_type and cpl_io_iosystem. want the original +! io capabilities to be usable by any component +! - the init1 method depends on seq_comm for name consistency but seq_comm_init +! wants to be called after init1 so the global_comm can be modified for +! async IO. this needs to be reconciled. +! - this routine stores information for all components but most methods are +! hardwired to work only for the coupler. should all the components info +! be stored here or should this be more a general set of methods that are +! reusable as it's original intent. +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_io_read_mod + + ! !USES: + + use shr_kind_mod, only: r8 => shr_kind_r8, in => shr_kind_in + use shr_kind_mod, only: cl => shr_kind_cl, cs => shr_kind_cs + use shr_pio_mod, only: shr_pio_getiosys, shr_pio_getiotype + use shr_sys_mod ! system calls + use seq_comm_mct + use mct_mod ! mct wrappers + use pio + + implicit none + private + + ! !PUBLIC TYPES: + + ! none + + ! !PUBLIC MEMBER FUNCTIONS: + + public seq_io_read + + ! !PUBLIC DATA MEMBERS + + ! none + + !EOP + + interface seq_io_read + module procedure seq_io_read_int + module procedure seq_io_read_int1d + module procedure seq_io_read_r8 + module procedure seq_io_read_r81d + module procedure seq_io_read_char + end interface + +!------------------------------------------------------------------------------- +! Local data +!------------------------------------------------------------------------------- + + character(*) , parameter :: prefix = "seq_io_" + character(*) , parameter :: version ='cpl7v10' + character(*) , parameter :: version0='cpl7v00' + character(CL) :: charvar ! buffer for string read/write + +!================================================================================= +contains +!================================================================================= + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_int - read scalar integer from netcdf file + ! + ! !DESCRIPTION: + ! Read scalar integer from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_int(filename,pioid,idata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(file_desc_t) :: pioid + integer ,intent(inout) :: idata ! integer data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer :: i1d(1) + character(*),parameter :: subName = '(seq_io_read_int) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_io_read_int1d(filename,pioid,i1d,dname) + idata = i1d(1) + + end subroutine seq_io_read_int + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_int1d - read 1d integer from netcdf file + ! + ! !DESCRIPTION: + ! Read 1d integer array from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_int1d(filename,pioid,idata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(file_desc_t) :: pioid + integer(in) ,intent(inout):: idata(:) ! integer data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + integer(in) :: rcode + type(var_desc_t) :: varid + logical :: exists + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_int1d) ' + logical :: addprefix + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + call seq_io_read_openfile(filename,pioid,addprefix) + + if (addprefix) then + name1 = trim(prefix)//trim(dname) + else + name1 = trim(dname) + endif + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,idata) + + end subroutine seq_io_read_int1d + + subroutine seq_io_read_openfile(filename,pioid,addprefix) + character(len=*), intent(in) :: filename + type(file_desc_t) :: pioid + logical, intent(out) :: addprefix + logical :: exists + integer(in) :: iam,mpicom + type(iosystem_desc_t) , pointer :: cpl_io_subsystem + character(len=seq_comm_namelen) :: cpl_name + integer(in) :: cpl_pio_iotype + logical, save :: laddprefix + integer :: rcode + character(CL) :: lversion + character(*),parameter :: subName = '(seq_io_read_openfile) ' + + if(.not. pio_file_is_open(pioid)) then + cpl_name = seq_comm_name(CPLID) + cpl_io_subsystem => shr_pio_getiosys(cpl_name) + cpl_pio_iotype = shr_pio_getiotype(cpl_name) + + call seq_comm_setptrs(CPLID,iam=iam,mpicom=mpicom) + if (iam==0) inquire(file=trim(filename),exist=exists) + call shr_mpi_bcast(exists,mpicom,'seq_io_read_openfile') + if (exists) then + rcode = pio_openfile(cpl_io_subsystem, pioid, cpl_pio_iotype, trim(filename),pio_nowrite) + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_get_att(pioid,pio_global,"file_version",lversion) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + if (trim(lversion) == trim(version)) then + laddprefix=.false. + else + laddprefix=.true. + endif + else + if(iam==0) write(logunit,*) subname,' ERROR: file invalid ',trim(filename) + call shr_sys_abort() + endif + endif + addprefix = laddprefix + + end subroutine seq_io_read_openfile + + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_r8 - read scalar double from netcdf file + ! + ! !DESCRIPTION: + ! Read scalar double from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_r8(filename,pioid,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(file_desc_t) :: pioid + real(r8) ,intent(inout) :: rdata ! real data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + real(r8) :: r1d(1) + character(*),parameter :: subName = '(seq_io_read_r8) ' + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + call seq_io_read_r81d(filename,pioid,r1d,dname) + rdata = r1d(1) + + end subroutine seq_io_read_r8 + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_r81d - read 1d double array from netcdf file + ! + ! !DESCRIPTION: + ! Read 1d double array from netcdf file + ! + ! !REVISION HISTORY: + ! 2007-Oct-26 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_r81d(filename,pioid,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(file_desc_t) :: pioid + real(r8) ,intent(inout) :: rdata(:) ! real data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + type(var_desc_t) :: varid + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_r81d) ' + logical :: addprefix + integer :: rcode + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + call seq_io_read_openfile(filename,pioid,addprefix) + + if (addprefix) then + name1 = trim(prefix)//trim(dname) + else + name1 = trim(dname) + endif + + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,rdata) + + end subroutine seq_io_read_r81d + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: seq_io_read_char - read char string from netcdf file + ! + ! !DESCRIPTION: + ! Read char string from netcdf file + ! + ! !REVISION HISTORY: + ! 2010-July-06 - T. Craig - initial version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine seq_io_read_char(filename,pioid,rdata,dname) + + ! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*),intent(in) :: filename ! file + type(file_desc_t) :: pioid + character(len=*),intent(inout) :: rdata ! character data + character(len=*),intent(in) :: dname ! name of data + + !EOP + + type(var_desc_t) :: varid + character(CL) :: name1 + character(*),parameter :: subName = '(seq_io_read_char) ' + logical :: addprefix + integer :: rcode + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + call seq_io_read_openfile(filename,pioid,addprefix) + + if (addprefix) then + name1 = trim(prefix)//trim(dname) + else + name1 = trim(dname) + endif + + rcode = pio_inq_varid(pioid,trim(name1),varid) + rcode = pio_get_var(pioid,varid,charvar) + rdata = trim(charvar) + + end subroutine seq_io_read_char + + !=============================================================================== +!=============================================================================== +end module seq_io_read_mod diff --git a/driver-mct/shr/seq_timemgr_mod.F90 b/driver-mct/shr/seq_timemgr_mod.F90 new file mode 100644 index 000000000000..59d9286b31a1 --- /dev/null +++ b/driver-mct/shr/seq_timemgr_mod.F90 @@ -0,0 +1,2583 @@ +!=============================================================================== +! +! !MODULE: seq_timemgr_mod --- Time-manager module +! +! !DESCRIPTION: +! +! A module to create derived types to manage time and clock information +! for use with CCSM drivers and models. +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2005-Nov-11 - E. Kluzek - creation as eshr_timemgr_mod +! 2007-Sep-12 - T. Craig - extended +! 2007-Oct-05 - T. Craig - refactored to support concurrent models +! 2007-Nov-15 - T. Craig - refactored for ccsm4 and renamed seq_timemgr_mod +! +! !INTERFACE: ------------------------------------------------------------------ + +module seq_timemgr_mod + +! !USES: + use ESMF + use shr_cal_mod + use SHR_KIND_mod, only: SHR_KIND_IN, SHR_KIND_R8, SHR_KIND_CS, & + SHR_KIND_CL, SHR_KIND_I8 + use seq_comm_mct, only: logunit, loglevel, seq_comm_iamin, CPLID, & + seq_comm_gloroot, seq_comm_iamroot + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + + implicit none + + private ! default private + +! ! PUBLIC TYPES: + + public :: seq_timemgr_type ! Wrapped clock object + +! ! PUBLIC MEMBER FUNCTIONS: + + ! --- Clock object methods -------------------------------------------------- + public :: seq_timemgr_clockInit ! Setup the sync clock + public :: seq_timemgr_clockAdvance ! Advance the sync clock + public :: seq_timemgr_clockPrint ! Print sync clock information + + public :: seq_timemgr_EClockGetData ! Get data from an ESMF clock + + public :: seq_timemgr_EClockDateInSync ! compare EClock to ymd/tod + public :: seq_timemgr_alarmSetOn ! Turn an alarm on + public :: seq_timemgr_alarmSetOff ! Turn an alarm off + public :: seq_timemgr_alarmIsOn ! Is an alarm ringing + public :: seq_timemgr_ETimeInit ! Create ESMF_Time object + public :: seq_timemgr_ETimeGet ! Query ESMF_Time object + + ! --- For usability, built on interfaces above --- + public :: seq_timemgr_restartAlarmIsOn ! Is a restart alarm ringing + public :: seq_timemgr_stopAlarmIsOn ! Is a stop alarm ringing + public :: seq_timemgr_historyAlarmIsOn ! Is a history alarm ringing + public :: seq_timemgr_pauseAlarmIsOn ! Is a pause alarm ringing + ! --- ESP components need to know about the state of other components + public :: seq_timemgr_pause_active ! Pause/resume is enabled + public :: seq_timemgr_pause_component_index ! Index of named component + public :: seq_timemgr_pause_component_active ! .true. is comp should pause + + ! ! PUBLIC PARAMETERS: + + integer(SHR_KIND_IN),public :: seq_timemgr_histavg_type + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_other = -1 + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_never = 1 + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_nhour = 2 + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_nday = 3 + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_nmonth = 4 + integer(SHR_KIND_IN),public,parameter :: seq_timemgr_type_nyear = 5 + + character(SHR_KIND_CL),public,parameter :: seq_timemgr_noleap = shr_cal_noleap + character(SHR_KIND_CL),public,parameter :: seq_timemgr_gregorian = shr_cal_gregorian + +! These are public but declared in the private area for clarity + +! clocknames: +! character(len=*),public,parameter :: & +! seq_timemgr_clock_drv +! seq_timemgr_clock_atm +! seq_timemgr_clock_lnd +! seq_timemgr_clock_rof +! seq_timemgr_clock_ocn +! seq_timemgr_clock_ice +! seq_timemgr_clock_glc +! seq_timemgr_clock_wav +! seq_timemgr_clock_esp + +! alarmnames: +! character(len=*),public,parameter :: & +! seq_timemgr_alarm_restart +! seq_timemgr_alarm_run +! seq_timemgr_alarm_stop +! seq_timemgr_alarm_datestop +! seq_timemgr_alarm_history +! seq_timemgr_alarm_atmrun +! seq_timemgr_alarm_lndrun +! seq_timemgr_alarm_rofrun +! seq_timemgr_alarm_ocnrun +! seq_timemgr_alarm_icerun +! seq_timemgr_alarm_glcrun +! seq_timemgr_alarm_glcrun_avg +! seq_timemgr_alarm_wavrun +! seq_timemgr_alarm_esprun +! seq_timemgr_alarm_ocnnext +! seq_timemgr_alarm_tprof +! seq_timemgr_alarm_histavg +! seq_timemgr_alarm_pause +! seq_timemgr_alarm_barrier + + private:: seq_timemgr_alarmGet + private:: seq_timemgr_alarmInit + private:: seq_timemgr_EClockInit + private:: seq_timemgr_ESMFDebug + private:: seq_timemgr_ESMFCodeCheck + + character(len=*), private, parameter :: & + seq_timemgr_optNONE = "none" , & + seq_timemgr_optNever = "never" , & + seq_timemgr_optNSteps = "nsteps" , & + seq_timemgr_optNStep = "nstep" , & + seq_timemgr_optNSeconds = "nseconds" , & + seq_timemgr_optNSecond = "nsecond" , & + seq_timemgr_optNMinutes = "nminutes" , & + seq_timemgr_optNMinute = "nminute" , & + seq_timemgr_optNHours = "nhours" , & + seq_timemgr_optNHour = "nhour" , & + seq_timemgr_optNDays = "ndays" , & + seq_timemgr_optNDay = "nday" , & + seq_timemgr_optNMonths = "nmonths" , & + seq_timemgr_optNMonth = "nmonth" , & + seq_timemgr_optNYears = "nyears" , & + seq_timemgr_optNYear = "nyear" , & + seq_timemgr_optMonthly = "monthly" , & + seq_timemgr_optYearly = "yearly" , & + seq_timemgr_optDate = "date" , & + seq_timemgr_optIfdays0 = "ifdays0" , & + seq_timemgr_optEnd = "end" , & + seq_timemgr_optGLCCouplingPeriod = "glc_coupling_period" + + integer(SHR_KIND_IN),private,parameter :: & + seq_timemgr_nclock_drv = 1, & + seq_timemgr_nclock_atm = 2, & + seq_timemgr_nclock_lnd = 3, & + seq_timemgr_nclock_ocn = 4, & + seq_timemgr_nclock_ice = 5, & + seq_timemgr_nclock_glc = 6, & + seq_timemgr_nclock_wav = 7, & + seq_timemgr_nclock_rof = 8, & + seq_timemgr_nclock_esp = 9 + + integer(SHR_KIND_IN),private,parameter :: max_clocks = 9 + character(len=*),public,parameter :: & + seq_timemgr_clock_drv = 'seq_timemgr_clock_drv' , & + seq_timemgr_clock_atm = 'seq_timemgr_clock_atm' , & + seq_timemgr_clock_lnd = 'seq_timemgr_clock_lnd' , & + seq_timemgr_clock_ocn = 'seq_timemgr_clock_ocn' , & + seq_timemgr_clock_ice = 'seq_timemgr_clock_ice' , & + seq_timemgr_clock_glc = 'seq_timemgr_clock_glc' , & + seq_timemgr_clock_wav = 'seq_timemgr_clock_wav' , & + seq_timemgr_clock_rof = 'seq_timemgr_clock_rof' , & + seq_timemgr_clock_esp = 'seq_timemgr_clock_esp' + character(len=8),private,parameter :: seq_timemgr_clocks(max_clocks) = & + (/'drv ','atm ','lnd ','ocn ', & + 'ice ','glc ','wav ','rof ','esp '/) + + ! Alarms on both component clocks and driver clock + integer(SHR_KIND_IN),private,parameter :: & + seq_timemgr_nalarm_restart = 1 , & ! driver and component clock alarm + seq_timemgr_nalarm_run = 2 , & ! driver and component clock alarm + seq_timemgr_nalarm_stop = 3 , & ! driver and component clock alarm + seq_timemgr_nalarm_datestop = 4 , & ! driver and component clock alarm + seq_timemgr_nalarm_history = 5 , & ! driver and component clock alarm + seq_timemgr_nalarm_atmrun = 6 , & ! driver only clock alarm + seq_timemgr_nalarm_lndrun = 7 , & ! driver only clock alarm + seq_timemgr_nalarm_ocnrun = 8 , & ! driver only clock alarm + seq_timemgr_nalarm_icerun = 9 , & ! driver only clock alarm + seq_timemgr_nalarm_glcrun =10 , & ! driver only clock alarm + seq_timemgr_nalarm_glcrun_avg =11 , & ! driver only clock alarm + seq_timemgr_nalarm_ocnnext =12 , & ! driver only clock alarm + seq_timemgr_nalarm_tprof =13 , & ! driver and component clock alarm + seq_timemgr_nalarm_histavg =14 , & ! driver and component clock alarm + seq_timemgr_nalarm_rofrun =15 , & ! driver only clock alarm + seq_timemgr_nalarm_wavrun =16 , & ! driver only clock alarm + seq_timemgr_nalarm_esprun =17 , & ! driver only clock alarm + seq_timemgr_nalarm_pause =18 , & + seq_timemgr_nalarm_barrier =19 , & ! driver and component clock alarm + max_alarms = seq_timemgr_nalarm_barrier + + character(len=*),public,parameter :: & + seq_timemgr_alarm_restart = 'seq_timemgr_alarm_restart ', & + seq_timemgr_alarm_run = 'seq_timemgr_alarm_run ', & + seq_timemgr_alarm_stop = 'seq_timemgr_alarm_stop ', & + seq_timemgr_alarm_datestop = 'seq_timemgr_alarm_datestop', & + seq_timemgr_alarm_history = 'seq_timemgr_alarm_history ', & + seq_timemgr_alarm_atmrun = 'seq_timemgr_alarm_atmrun ', & + seq_timemgr_alarm_lndrun = 'seq_timemgr_alarm_lndrun ', & + seq_timemgr_alarm_ocnrun = 'seq_timemgr_alarm_ocnrun ', & + seq_timemgr_alarm_icerun = 'seq_timemgr_alarm_icerun ', & + seq_timemgr_alarm_glcrun = 'seq_timemgr_alarm_glcrun ', & + seq_timemgr_alarm_glcrun_avg = 'seq_timemgr_alarm_glcrun_avg' , & + seq_timemgr_alarm_ocnnext = 'seq_timemgr_alarm_ocnnext ', & + seq_timemgr_alarm_tprof = 'seq_timemgr_alarm_tprof ', & + seq_timemgr_alarm_histavg = 'seq_timemgr_alarm_histavg ', & + seq_timemgr_alarm_rofrun = 'seq_timemgr_alarm_rofrun ', & + seq_timemgr_alarm_wavrun = 'seq_timemgr_alarm_wavrun ', & + seq_timemgr_alarm_esprun = 'seq_timemgr_alarm_esprun ', & + seq_timemgr_alarm_pause = 'seq_timemgr_alarm_pause ', & + seq_timemgr_alarm_barrier = 'seq_timemgr_alarm_barrier ' + + ! Active pause - resume components + logical, private :: pause_active(max_clocks) = .false. + + type EClock_pointer ! needed for array of pointers + type(ESMF_Clock),pointer :: EClock => null() + end type EClock_pointer + + type seq_timemgr_type + private + type(EClock_pointer) :: ECP(max_clocks) ! ESMF clocks, array of pointers + type(ESMF_Alarm) :: EAlarm(max_clocks,max_alarms) ! array of clock alarms + end type seq_timemgr_type + + ! --- Private local data ---------------------------------------------------- + + type(ESMF_Calendar), target, save :: seq_timemgr_cal ! calendar + character(SHR_KIND_CL) ,save :: seq_timemgr_calendar ! calendar string + integer, parameter :: SecPerDay = 86400 ! Seconds per day + + integer :: seq_timemgr_pause_sig_index ! Index of pause comp with smallest dt + logical :: seq_timemgr_esp_run_on_pause ! Run ESP component on pause cycle + logical :: seq_timemgr_end_restart ! write restarts at end of run? + +!=============================================================================== + +contains + +!=============================================================================== +! !IROUTINE: seq_timemgr_clockInit -- Initializes clocks +! +! !DESCRIPTION: +! +! Initializes clock +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_clockInit(SyncClock, nmlfile, restart, restart_file, pioid, mpicom, & + EClock_drv, EClock_atm, EClock_lnd, EClock_ocn, EClock_ice, Eclock_glc, & + Eclock_rof, EClock_wav, Eclock_esp) + +! !USES: + use pio, only : file_desc_T + use shr_file_mod, only : shr_file_getunit, shr_file_freeunit + use shr_mpi_mod, only : shr_mpi_bcast + use seq_io_read_mod + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_timemgr_type), intent(INOUT) :: SyncClock ! sync clock + character(len=*), intent(IN) :: nmlfile ! namelist file + integer, intent(IN) :: mpicom ! MPI communicator + logical, intent(IN) :: restart ! restart logical + character(len=*), intent(IN) :: restart_file + type(ESMF_clock),target, intent(IN) :: EClock_drv ! drv clock + type(ESMF_clock),target, intent(IN) :: EClock_atm ! atm clock + type(ESMF_clock),target, intent(IN) :: EClock_lnd ! lnd clock + type(ESMF_clock),target, intent(IN) :: EClock_ocn ! ocn clock + type(ESMF_clock),target, intent(IN) :: EClock_ice ! ice clock + type(ESMF_clock),target, intent(IN) :: EClock_glc ! glc clock + type(ESMF_clock),target, intent(IN) :: EClock_rof ! rof clock + type(ESMF_clock),target, intent(IN) :: EClock_wav ! wav clock + type(ESMF_clock),target, intent(IN) :: EClock_esp ! esp clock + type(file_desc_t) :: pioid + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_clockInit) ' + type(ESMF_Time) :: StartTime ! Start time + type(ESMF_Time) :: RefTime ! Reference time + type(ESMF_Time) :: CurrTime ! Current time + type(ESMF_Time) :: OffsetTime ! local computed time + type(ESMF_Time) :: StopTime1 ! Stop time + type(ESMF_Time) :: StopTime2 ! Stop time + type(ESMF_TimeInterval) :: TimeStep ! Clock time-step + type(ESMF_CalKind_Flag) :: esmf_caltype ! local esmf calendar + integer :: rc ! Return code + integer :: n, i ! index + logical :: found + integer :: min_dt ! smallest time step + integer :: dtime(max_clocks) ! time-step to use + integer :: offset(max_clocks) ! run offset + integer :: unitn ! i/o unit number + integer :: iam ! pe rank + + character(SHR_KIND_CS) :: calendar ! Calendar type + character(SHR_KIND_CS) :: stop_option ! Stop option units + integer(SHR_KIND_IN) :: stop_n ! Number until stop + integer(SHR_KIND_IN) :: stop_ymd ! Stop date (YYYYMMDD) + integer(SHR_KIND_IN) :: stop_tod ! Stop time-of-day + character(SHR_KIND_CS) :: restart_option ! Restart option units + integer(SHR_KIND_IN) :: restart_n ! Number until restart interval + integer(SHR_KIND_IN) :: restart_ymd ! Restart date (YYYYMMDD) + character(SHR_KIND_CS) :: pause_option ! Pause option units + integer(SHR_KIND_IN) :: pause_n ! Number between pause intervals + + logical :: data_assimilation_atm + logical :: data_assimilation_cpl + logical :: data_assimilation_ocn + logical :: data_assimilation_wav + logical :: data_assimilation_glc + logical :: data_assimilation_ice + logical :: data_assimilation_rof + logical :: data_assimilation_lnd + + character(SHR_KIND_CS) :: history_option ! History option units + integer(SHR_KIND_IN) :: history_n ! Number until history interval + integer(SHR_KIND_IN) :: history_ymd ! History date (YYYYMMDD) + character(SHR_KIND_CS) :: histavg_option ! Histavg option units + integer(SHR_KIND_IN) :: histavg_n ! Number until histavg interval + integer(SHR_KIND_IN) :: histavg_ymd ! Histavg date (YYYYMMDD) + character(SHR_KIND_CS) :: barrier_option ! Barrier option units + integer(SHR_KIND_IN) :: barrier_n ! Number until barrier interval + integer(SHR_KIND_IN) :: barrier_ymd ! Barrier date (YYYYMMDD) + character(SHR_KIND_CS) :: tprof_option ! tprof option units + integer(SHR_KIND_IN) :: tprof_n ! Number until tprof interval + integer(SHR_KIND_IN) :: tprof_ymd ! tprof date (YYYYMMDD) + integer(SHR_KIND_IN) :: start_ymd ! Start date (YYYYMMDD) + integer(SHR_KIND_IN) :: start_tod ! Start time of day (seconds) + integer(SHR_KIND_IN) :: curr_ymd ! Current ymd (YYYYMMDD) + integer(SHR_KIND_IN) :: curr_tod ! Current tod (seconds) + integer(SHR_KIND_IN) :: ref_ymd ! Reference date (YYYYMMDD) + integer(SHR_KIND_IN) :: ref_tod ! Reference time of day (seconds) + integer(SHR_KIND_IN) :: atm_cpl_dt ! Atmosphere coupling interval + integer(SHR_KIND_IN) :: lnd_cpl_dt ! Land coupling interval + integer(SHR_KIND_IN) :: ice_cpl_dt ! Sea-Ice coupling interval + integer(SHR_KIND_IN) :: ocn_cpl_dt ! Ocean coupling interval + integer(SHR_KIND_IN) :: glc_cpl_dt ! Glc coupling interval + character(SHR_KIND_CS) :: glc_avg_period ! Glc avering coupling period + integer(SHR_KIND_IN) :: rof_cpl_dt ! Runoff coupling interval + integer(SHR_KIND_IN) :: wav_cpl_dt ! Wav coupling interval + integer(SHR_KIND_IN) :: esp_cpl_dt ! Esp coupling interval + integer(SHR_KIND_IN) :: atm_cpl_offset ! Atmosphere coupling interval + integer(SHR_KIND_IN) :: lnd_cpl_offset ! Land coupling interval + integer(SHR_KIND_IN) :: ice_cpl_offset ! Sea-Ice coupling interval + integer(SHR_KIND_IN) :: ocn_cpl_offset ! Ocean coupling interval + integer(SHR_KIND_IN) :: glc_cpl_offset ! Glc coupling interval + integer(SHR_KIND_IN) :: wav_cpl_offset ! Wav coupling interval + integer(SHR_KIND_IN) :: rof_cpl_offset ! Runoff coupling interval + integer(SHR_KIND_IN) :: esp_cpl_offset ! Esp coupling interval + logical :: esp_run_on_pause ! Run ESP on pause cycle + logical :: end_restart ! Write restart at end of run + integer(SHR_KIND_IN) :: ierr ! Return code + + character(len=*), parameter :: F0A = "(2A,A)" + character(len=*), parameter :: F0I = "(2A,I10)" + character(len=*), parameter :: F0L = "(2A,L3)" + + namelist /seq_timemgr_inparm/ calendar, curr_ymd, curr_tod, & + stop_option, stop_n, stop_ymd, stop_tod, & + restart_option, restart_n, restart_ymd, & + pause_option, & + pause_n, & + data_assimilation_atm, & + data_assimilation_cpl, & + data_assimilation_ocn, & + data_assimilation_wav, & + data_assimilation_glc, & + data_assimilation_ice, & + data_assimilation_rof, & + data_assimilation_lnd, & + history_option, history_n, history_ymd, & + histavg_option, histavg_n, histavg_ymd, & + barrier_option, barrier_n, barrier_ymd, & + tprof_option, tprof_n, tprof_ymd, & + start_ymd, start_tod, ref_ymd, ref_tod, & + atm_cpl_dt, ocn_cpl_dt, ice_cpl_dt, lnd_cpl_dt, & + atm_cpl_offset, lnd_cpl_offset, ocn_cpl_offset, & + ice_cpl_offset, glc_cpl_dt, glc_cpl_offset, glc_avg_period, & + wav_cpl_dt, wav_cpl_offset, esp_cpl_dt, esp_cpl_offset, & + rof_cpl_dt, rof_cpl_offset, esp_run_on_pause, end_restart +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + SyncClock%ECP(seq_timemgr_nclock_drv)%EClock => EClock_drv + SyncClock%ECP(seq_timemgr_nclock_atm)%EClock => EClock_atm + SyncClock%ECP(seq_timemgr_nclock_lnd)%EClock => EClock_lnd + SyncClock%ECP(seq_timemgr_nclock_ocn)%EClock => EClock_ocn + SyncClock%ECP(seq_timemgr_nclock_ice)%EClock => EClock_ice + SyncClock%ECP(seq_timemgr_nclock_glc)%EClock => EClock_glc + SyncClock%ECP(seq_timemgr_nclock_rof)%EClock => EClock_rof + SyncClock%ECP(seq_timemgr_nclock_wav)%EClock => EClock_wav + SyncClock%ECP(seq_timemgr_nclock_esp)%EClock => EClock_esp + + call mpi_comm_rank(mpicom,iam,ierr) + + !--------------------------------------------------------------------------- + ! Set syncclock on root pe + !--------------------------------------------------------------------------- + + if (iam == 0) then + + !--------------------------------------------------------------------------- + ! Set namelist defaults + !--------------------------------------------------------------------------- + calendar = seq_timemgr_noleap + stop_option = ' ' + stop_n = -1 + stop_ymd = -1 + stop_tod = 0 + restart_option = seq_timemgr_optYearly + restart_n = -1 + restart_ymd = -1 + pause_option = seq_timemgr_optNever + pause_n = -1 + data_assimilation_atm = .false. + data_assimilation_cpl = .false. + data_assimilation_ocn = .false. + data_assimilation_wav = .false. + data_assimilation_glc = .false. + data_assimilation_ice = .false. + data_assimilation_rof = .false. + data_assimilation_lnd = .false. + + history_option = seq_timemgr_optNever + history_n = -1 + history_ymd = -1 + histavg_option = seq_timemgr_optNever + histavg_n = -1 + histavg_ymd = -1 + barrier_option = seq_timemgr_optNever + barrier_n = -1 + barrier_ymd = -1 + tprof_option = seq_timemgr_optNever + tprof_n = -1 + tprof_ymd = -1 + start_ymd = 0 + start_tod = 0 + ref_ymd = 0 + ref_tod = 0 + curr_ymd = 0 + curr_tod = 0 + atm_cpl_dt = 0 + lnd_cpl_dt = 0 + ice_cpl_dt = 0 + ocn_cpl_dt = 0 + glc_cpl_dt = 0 + glc_avg_period = seq_timemgr_optGLCCouplingPeriod + rof_cpl_dt = 0 + wav_cpl_dt = 0 + esp_cpl_dt = 0 + atm_cpl_offset = 0 + lnd_cpl_offset = 0 + ice_cpl_offset = 0 + ocn_cpl_offset = 0 + glc_cpl_offset = 0 + rof_cpl_offset = 0 + wav_cpl_offset = 0 + esp_cpl_offset = 0 + esp_run_on_pause = .true. + end_restart = .true. + + !--------------------------------------------------------------------------- + ! Read in namelist + !--------------------------------------------------------------------------- + unitn = shr_file_getUnit() + write(logunit,F0A) trim(subname),' Read in seq_timemgr_inparm namelist from: '//trim(nmlfile) + open( unitn, file=trim(nmlfile), status='old' ) + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=seq_timemgr_inparm,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' end of file or end of record condition' ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + endif + + !--------------------------------------------------------------------------- + ! Read Restart (seq_io is called on all CPLID pes) + ! NOTE: slightly messy, seq_io is only valid on CPLID + !--------------------------------------------------------------------------- + if (restart) then + if (seq_comm_iamin(CPLID)) then + call seq_io_read(restart_file,pioid,start_ymd,'seq_timemgr_start_ymd') + call seq_io_read(restart_file,pioid,start_tod,'seq_timemgr_start_tod') + call seq_io_read(restart_file,pioid,ref_ymd ,'seq_timemgr_ref_ymd') + call seq_io_read(restart_file,pioid,ref_tod ,'seq_timemgr_ref_tod') + call seq_io_read(restart_file,pioid,curr_ymd ,'seq_timemgr_curr_ymd') + call seq_io_read(restart_file,pioid,curr_tod ,'seq_timemgr_curr_tod') + endif + !--- Send from CPLID ROOT to GLOBALID ROOT, use bcast as surrogate + call shr_mpi_bcast(start_ymd,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast(start_tod,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast( ref_ymd,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast( ref_tod,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast( curr_ymd,mpicom,pebcast=seq_comm_gloroot(CPLID)) + call shr_mpi_bcast( curr_tod,mpicom,pebcast=seq_comm_gloroot(CPLID)) + endif + + if (iam == 0) then + !--------------------------------------------------------------------------- + ! Modify namelist as needed + !--------------------------------------------------------------------------- + + if (lnd_cpl_dt == 0) lnd_cpl_dt = atm_cpl_dt ! Copy atm coupling time into lnd + if (rof_cpl_dt == 0) rof_cpl_dt = atm_cpl_dt ! Copy atm coupling time into rof + if (ice_cpl_dt == 0) ice_cpl_dt = atm_cpl_dt ! Copy atm coupling time into ice + if (ocn_cpl_dt == 0) ocn_cpl_dt = atm_cpl_dt ! Copy atm coupling time into ocn + if (glc_cpl_dt == 0) glc_cpl_dt = atm_cpl_dt ! Copy atm coupling time into glc + if (wav_cpl_dt == 0) wav_cpl_dt = atm_cpl_dt ! Copy atm coupling time into wav + if (esp_cpl_dt == 0) esp_cpl_dt = atm_cpl_dt ! Copy atm coupling time into esp + + if ( ref_ymd == 0 ) then + ref_ymd = start_ymd + ref_tod = start_tod + endif + + if ( curr_ymd == 0 ) then + curr_ymd = start_ymd + curr_tod = start_tod + endif + + if ( stop_ymd < 0) then + stop_ymd = 99990101 + stop_tod = 0 + endif + + if (trim(restart_option) == trim(seq_timemgr_optNone) .or. & + trim(restart_option) == trim(seq_timemgr_optNever)) then + if (end_restart) then + end_restart = .false. + write(logunit,F0A) trim(subname),' WARNING: overriding end_restart to '// & + 'false based on restart_option ' + endif + endif + + if (trim(restart_option) == trim(seq_timemgr_optEnd)) then + restart_option = seq_timemgr_optNone + write(logunit,F0A) trim(subname),' WARNING: overriding restart_option to '// & + 'none and verifying end_restart flag is true ' + if (.not. end_restart) then + end_restart = .true. + write(logunit,F0A) trim(subname),' WARNING: overriding end_restart to '// & + 'true based on restart_option (end) ' + endif + endif + + !--------------------------------------------------------------------------- + ! Print out the namelist settings + !--------------------------------------------------------------------------- + + write(logunit,F0A) ' ' + write(logunit,F0A) trim(subname),' Clock Init Settings:' + write(logunit,F0A) trim(subname),' calendar = ',trim(calendar) + write(logunit,F0A) trim(subname),' stop_option = ',trim(stop_option) + write(logunit,F0I) trim(subname),' stop_n = ',stop_n + write(logunit,F0I) trim(subname),' stop_ymd = ',stop_ymd + write(logunit,F0I) trim(subname),' stop_tod = ',stop_tod + write(logunit,F0A) trim(subname),' restart_option = ',trim(restart_option) + write(logunit,F0I) trim(subname),' restart_n = ',restart_n + write(logunit,F0I) trim(subname),' restart_ymd = ',restart_ymd + write(logunit,F0L) trim(subname),' end_restart = ',end_restart + write(logunit,F0A) trim(subname),' pause_option = ',& + trim(pause_option) + write(logunit,F0I) trim(subname),' pause_n = ',& + pause_n + write(logunit,F0L) trim(subname),' esp_run_on_pause = ',esp_run_on_pause + write(logunit,F0A) trim(subname),' history_option = ',trim(history_option) + write(logunit,F0I) trim(subname),' history_n = ',history_n + write(logunit,F0I) trim(subname),' history_ymd = ',history_ymd + write(logunit,F0A) trim(subname),' histavg_option = ',trim(histavg_option) + write(logunit,F0I) trim(subname),' histavg_n = ',histavg_n + write(logunit,F0I) trim(subname),' histavg_ymd = ',histavg_ymd + write(logunit,F0A) trim(subname),' barrier_option = ',trim(barrier_option) + write(logunit,F0I) trim(subname),' barrier_n = ',barrier_n + write(logunit,F0I) trim(subname),' barrier_ymd = ',barrier_ymd + write(logunit,F0A) trim(subname),' tprof_option = ',trim(tprof_option) + write(logunit,F0I) trim(subname),' tprof_n = ',tprof_n + write(logunit,F0I) trim(subname),' tprof_ymd = ',tprof_ymd + write(logunit,F0I) trim(subname),' start_ymd = ',start_ymd + write(logunit,F0I) trim(subname),' start_tod = ',start_tod + write(logunit,F0I) trim(subname),' ref_ymd = ',ref_ymd + write(logunit,F0I) trim(subname),' ref_tod = ',ref_tod + write(logunit,F0I) trim(subname),' atm_cpl_dt = ',atm_cpl_dt + write(logunit,F0I) trim(subname),' lnd_cpl_dt = ',lnd_cpl_dt + write(logunit,F0I) trim(subname),' ice_cpl_dt = ',ice_cpl_dt + write(logunit,F0I) trim(subname),' ocn_cpl_dt = ',ocn_cpl_dt + write(logunit,F0I) trim(subname),' glc_cpl_dt = ',glc_cpl_dt + write(logunit,F0A) trim(subname),' glc_avg_period = ',glc_avg_period + write(logunit,F0I) trim(subname),' rof_cpl_dt = ',rof_cpl_dt + write(logunit,F0I) trim(subname),' wav_cpl_dt = ',wav_cpl_dt + write(logunit,F0I) trim(subname),' esp_cpl_dt = ',esp_cpl_dt + write(logunit,F0I) trim(subname),' atm_cpl_offset = ',atm_cpl_offset + write(logunit,F0I) trim(subname),' lnd_cpl_offset = ',lnd_cpl_offset + write(logunit,F0I) trim(subname),' ice_cpl_offset = ',ice_cpl_offset + write(logunit,F0I) trim(subname),' ocn_cpl_offset = ',ocn_cpl_offset + write(logunit,F0I) trim(subname),' glc_cpl_offset = ',glc_cpl_offset + write(logunit,F0I) trim(subname),' rof_cpl_offset = ',rof_cpl_offset + write(logunit,F0I) trim(subname),' wav_cpl_offset = ',wav_cpl_offset + write(logunit,F0I) trim(subname),' esp_cpl_offset = ',esp_cpl_offset + write(logunit,F0A) ' ' + + !--------------------------------------------------------------------------- + ! Check a few things + !--------------------------------------------------------------------------- + + ! --- Coupling intervals ------------------------------------------------ + if ( atm_cpl_dt <= 0 .or. & + lnd_cpl_dt /= atm_cpl_dt .or. & + ice_cpl_dt /= atm_cpl_dt .or. & + ocn_cpl_dt <= 0 .or. glc_cpl_dt <= 0 .or. rof_cpl_dt <=0 .or. & + wav_cpl_dt <=0 .or. esp_cpl_dt <=0) then + write(logunit,*) trim(subname),' ERROR: aliogrwe _cpl_dt = ', & + atm_cpl_dt, lnd_cpl_dt, ice_cpl_dt, ocn_cpl_dt, glc_cpl_dt, & + rof_cpl_dt, wav_cpl_dt, esp_cpl_dt + call shr_sys_abort( subname//': ERROR coupling intervals invalid' ) + end if + + ! --- Coupling offsets -------------------------------------------------- + if ( abs(atm_cpl_offset) > atm_cpl_dt .or. & + abs(lnd_cpl_offset) > lnd_cpl_dt .or. & + abs(ice_cpl_offset) > ice_cpl_dt .or. & + abs(glc_cpl_offset) > glc_cpl_dt .or. & + abs(rof_cpl_offset) > rof_cpl_dt .or. & + abs(wav_cpl_offset) > wav_cpl_dt .or. & + abs(esp_cpl_offset) > esp_cpl_dt .or. & + abs(ocn_cpl_offset) > ocn_cpl_dt) then + write(logunit,*) trim(subname),' ERROR: aliogrwe _cpl_offset = ', & + atm_cpl_offset, lnd_cpl_offset, ice_cpl_offset, ocn_cpl_offset, & + glc_cpl_offset, rof_cpl_offset, wav_cpl_offset, esp_cpl_offset + call shr_sys_abort( subname//': ERROR coupling offsets invalid' ) + end if + + ! --- Start time date --------------------------------------------------- + if ( (start_ymd < 101) .or. (start_ymd > 99991231)) then + write(logunit,*) subname,' ERROR: illegal start_ymd',start_ymd + call shr_sys_abort( subname//': ERROR invalid start_ymd') + end if + + endif + + !--------------------------------------------------------------------------- + ! Broadcast namelist data + !--------------------------------------------------------------------------- + call shr_mpi_bcast( calendar, mpicom ) + call shr_mpi_bcast( stop_n, mpicom ) + call shr_mpi_bcast( stop_option, mpicom ) + call shr_mpi_bcast( stop_ymd, mpicom ) + call shr_mpi_bcast( stop_tod, mpicom ) + call shr_mpi_bcast( restart_n, mpicom ) + call shr_mpi_bcast( restart_option, mpicom ) + call shr_mpi_bcast( restart_ymd, mpicom ) + call shr_mpi_bcast( pause_n, mpicom ) + call shr_mpi_bcast( pause_option, mpicom ) + call shr_mpi_bcast(data_assimilation_atm, mpicom) + call shr_mpi_bcast(data_assimilation_cpl, mpicom) + call shr_mpi_bcast(data_assimilation_ocn, mpicom) + call shr_mpi_bcast(data_assimilation_wav, mpicom) + call shr_mpi_bcast(data_assimilation_glc, mpicom) + call shr_mpi_bcast(data_assimilation_ice, mpicom) + call shr_mpi_bcast(data_assimilation_rof, mpicom) + call shr_mpi_bcast(data_assimilation_lnd, mpicom) + + call shr_mpi_bcast( history_n, mpicom ) + call shr_mpi_bcast( history_option, mpicom ) + call shr_mpi_bcast( history_ymd, mpicom ) + call shr_mpi_bcast( histavg_n, mpicom ) + call shr_mpi_bcast( histavg_option, mpicom ) + call shr_mpi_bcast( histavg_ymd, mpicom ) + call shr_mpi_bcast( tprof_n, mpicom ) + call shr_mpi_bcast( barrier_n, mpicom ) + call shr_mpi_bcast( barrier_option, mpicom ) + call shr_mpi_bcast( barrier_ymd, mpicom ) + call shr_mpi_bcast( tprof_option, mpicom ) + call shr_mpi_bcast( tprof_ymd, mpicom ) + call shr_mpi_bcast( start_ymd, mpicom ) + call shr_mpi_bcast( start_tod, mpicom ) + call shr_mpi_bcast( ref_ymd, mpicom ) + call shr_mpi_bcast( ref_tod, mpicom ) + call shr_mpi_bcast( curr_ymd, mpicom ) + call shr_mpi_bcast( curr_tod, mpicom ) + call shr_mpi_bcast( atm_cpl_dt, mpicom ) + call shr_mpi_bcast( lnd_cpl_dt, mpicom ) + call shr_mpi_bcast( ice_cpl_dt, mpicom ) + call shr_mpi_bcast( ocn_cpl_dt, mpicom ) + call shr_mpi_bcast( glc_cpl_dt, mpicom ) + call shr_mpi_bcast( glc_avg_period, mpicom ) + call shr_mpi_bcast( rof_cpl_dt, mpicom ) + call shr_mpi_bcast( wav_cpl_dt, mpicom ) + call shr_mpi_bcast( esp_cpl_dt, mpicom ) + call shr_mpi_bcast( atm_cpl_offset, mpicom ) + call shr_mpi_bcast( lnd_cpl_offset, mpicom ) + call shr_mpi_bcast( ice_cpl_offset, mpicom ) + call shr_mpi_bcast( ocn_cpl_offset, mpicom ) + call shr_mpi_bcast( glc_cpl_offset, mpicom ) + call shr_mpi_bcast( rof_cpl_offset, mpicom ) + call shr_mpi_bcast( wav_cpl_offset, mpicom ) + call shr_mpi_bcast( esp_cpl_offset, mpicom ) + call shr_mpi_bcast( esp_run_on_pause, mpicom ) + call shr_mpi_bcast( end_restart, mpicom ) + + ! --- derive a couple things --- + if (trim(histavg_option) == trim(seq_timemgr_optNever) .or. & + trim(histavg_option) == trim(seq_timemgr_optNone)) then + seq_timemgr_histavg_type = seq_timemgr_type_never + elseif (trim(histavg_option) == trim(seq_timemgr_optNHours) .or. & + trim(histavg_option) == trim(seq_timemgr_optNHour)) then + seq_timemgr_histavg_type = seq_timemgr_type_nhour + elseif (trim(histavg_option) == trim(seq_timemgr_optNDays) .or. & + trim(histavg_option) == trim(seq_timemgr_optNDay)) then + seq_timemgr_histavg_type = seq_timemgr_type_nday + elseif (trim(histavg_option) == trim(seq_timemgr_optNMonths) .or. & + trim(histavg_option) == trim(seq_timemgr_optNMonth) .or. & + trim(histavg_option) == trim(seq_timemgr_optMonthly)) then + seq_timemgr_histavg_type = seq_timemgr_type_nmonth + elseif (trim(histavg_option) == trim(seq_timemgr_optNYears) .or. & + trim(histavg_option) == trim(seq_timemgr_optNYear) .or. & + trim(histavg_option) == trim(seq_timemgr_optYearly)) then + seq_timemgr_histavg_type = seq_timemgr_type_nyear + else + seq_timemgr_histavg_type = seq_timemgr_type_other + endif + + + ! --- Initialize generic stuff --- + seq_timemgr_calendar = shr_cal_calendarName(calendar) + seq_timemgr_esp_run_on_pause = esp_run_on_pause + seq_timemgr_end_restart = end_restart + ! --- Figure out which components (if any) are doing pause this run + rc = 1 + i = 1 + if (data_assimilation_atm) then + pause_active(seq_timemgr_nclock_atm) = .true. + endif + if (data_assimilation_cpl) then + pause_active(seq_timemgr_nclock_drv) = .true. + endif + if (data_assimilation_ocn) then + pause_active(seq_timemgr_nclock_ocn) = .true. + endif + if (data_assimilation_wav) then + pause_active(seq_timemgr_nclock_wav) = .true. + endif + if (data_assimilation_glc) then + pause_active(seq_timemgr_nclock_glc) = .true. + endif + if (data_assimilation_ice) then + pause_active(seq_timemgr_nclock_ice) = .true. + endif + if (data_assimilation_rof) then + pause_active(seq_timemgr_nclock_rof) = .true. + endif + if (data_assimilation_lnd) then + pause_active(seq_timemgr_nclock_lnd) = .true. + endif + + if ( ANY(pause_active) .and. & + (trim(pause_option) /= seq_timemgr_optNONE) .and. & + (trim(pause_option) /= seq_timemgr_optNever)) then + do n = 1, max_clocks + if (pause_active(n) .and. (iam == 0)) then + write(logunit, '(4a)') subname, ': Pause active for ', & + trim(seq_timemgr_clocks(n)),' component' + end if + end do + end if + + ! --- Create the new calendar if not already set ------ + if ( trim(seq_timemgr_calendar) == trim(seq_timemgr_noleap)) then + esmf_caltype = ESMF_CALKIND_NOLEAP + else if ( trim(seq_timemgr_calendar) == trim(seq_timemgr_gregorian)) then + esmf_caltype = ESMF_CALKIND_GREGORIAN + else + write(logunit,*) subname//': unrecognized ESMF calendar specified: '// & + trim(seq_timemgr_calendar) + call shr_sys_abort( subname//'ERROR:: bad calendar for ESMF' ) + end if + + seq_timemgr_cal = ESMF_CalendarCreate( name='CCSM_'//seq_timemgr_calendar, & + calkindflag=esmf_caltype, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, subname//': error return from ESMF_CalendarCreate' ) + + ! --- Initialize start, ref, and current date --- + + call seq_timemgr_ETimeInit( StartTime, start_ymd, start_tod, "Start date" ) + call seq_timemgr_ETimeInit( RefTime , ref_ymd , ref_tod , "Reference date" ) + call seq_timemgr_ETimeInit( CurrTime , curr_ymd , curr_tod , "Current date") + + ! --- Figure out what time-stepping interval should be. --------------- + + dtime = 0 + dtime(seq_timemgr_nclock_atm ) = atm_cpl_dt + dtime(seq_timemgr_nclock_lnd ) = lnd_cpl_dt + dtime(seq_timemgr_nclock_ocn ) = ocn_cpl_dt + dtime(seq_timemgr_nclock_ice ) = ice_cpl_dt + dtime(seq_timemgr_nclock_glc ) = glc_cpl_dt + dtime(seq_timemgr_nclock_rof ) = rof_cpl_dt + dtime(seq_timemgr_nclock_wav ) = wav_cpl_dt + dtime(seq_timemgr_nclock_esp ) = esp_cpl_dt + + ! --- this finds the min of dtime excluding the driver value --- + dtime(seq_timemgr_nclock_drv) = maxval(dtime) + dtime(seq_timemgr_nclock_drv) = minval(dtime) + + ! --- For figuring pause cycle + min_dt = maxval(dtime) + seq_timemgr_pause_sig_index = -1 + + do n = 1,max_clocks + if ( mod(dtime(n),dtime(seq_timemgr_nclock_drv)) /= 0) then + write(logunit,*) trim(subname),' ERROR: dtime inconsistent = ',dtime + call shr_sys_abort( subname//' :coupling intervals not compatible' ) + endif + if (pause_active(n) .and. (dtime(n) < min_dt)) then + min_dt = dtime(n) + seq_timemgr_pause_sig_index = n + end if + enddo + if (ANY(pause_active)) then + if (seq_timemgr_pause_sig_index < 1) then + write(logunit, *) subname,"ERROR: No pause_sig_index even with active pause" + call shr_sys_abort(subname//"ERROR: No pause_sig_index even with active pause") + end if + else + ! Don't try to run ESP on non-existent pauses + seq_timemgr_esp_run_on_pause = .false. + end if + + ! --- Initialize component and driver clocks and alarms common to components and driver clocks --- + + do n = 1,max_clocks + call ESMF_TimeIntervalSet( TimeStep, s=dtime(n), rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, subname//': error ESMF_TimeIntervalSet' ) + + call seq_timemgr_EClockInit( TimeStep, StartTime, RefTime, CurrTime, SyncClock%ECP(n)%EClock) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_run), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(n), & + RefTime = CurrTime, & + alarmname = trim(seq_timemgr_alarm_run)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_stop), & + option = stop_option, & + opt_n = stop_n, & + opt_ymd = stop_ymd, & + opt_tod = stop_tod, & + RefTime = CurrTime, & + alarmname = trim(seq_timemgr_alarm_stop)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_datestop), & + option = seq_timemgr_optDate, & + opt_ymd = stop_ymd, & + opt_tod = stop_tod, & + RefTime = StartTime, & + alarmname = trim(seq_timemgr_alarm_datestop)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_restart), & + option = restart_option, & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = CurrTime, & + alarmname = trim(seq_timemgr_alarm_restart)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_history), & + option = history_option, & + opt_n = history_n, & + opt_ymd = history_ymd, & + RefTime = StartTime, & + alarmname = trim(seq_timemgr_alarm_history)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_histavg), & + option = histavg_option, & + opt_n = histavg_n, & + opt_ymd = histavg_ymd, & + RefTime = StartTime, & + alarmname = trim(seq_timemgr_alarm_histavg)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_barrier), & + option = barrier_option, & + opt_n = barrier_n, & + opt_ymd = barrier_ymd, & + RefTime = CurrTime, & + alarmname = trim(seq_timemgr_alarm_barrier)) + + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_tprof), & + option = tprof_option, & + opt_n = tprof_n, & + opt_ymd = tprof_ymd, & + RefTime = StartTime, & + alarmname = trim(seq_timemgr_alarm_tprof)) + + call ESMF_AlarmGet(SyncClock%EAlarm(n,seq_timemgr_nalarm_stop), RingTime=StopTime1, rc=rc ) + call ESMF_AlarmGet(SyncClock%EAlarm(n,seq_timemgr_nalarm_datestop), RingTime=StopTime2, rc=rc ) + if (StopTime2 < StopTime1) then + call ESMF_ClockSet(SyncClock%ECP(n)%EClock, StopTime=StopTime2) + else + call ESMF_ClockSet(SyncClock%ECP(n)%EClock, StopTime=StopTime1) + endif + + ! Set the pause option if pause/resume is active + if (pause_active(n)) then + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_pause), & + option = pause_option, & + opt_n = pause_n, & + RefTime = CurrTime, & + alarmname = trim(seq_timemgr_alarm_pause)) + else + call seq_timemgr_alarmInit(SyncClock%ECP(n)%EClock, & + EAlarm = SyncClock%EAlarm(n,seq_timemgr_nalarm_pause), & + option = seq_timemgr_optNever, & + opt_n = -1, & + RefTime = StartTime, & + alarmname = trim(seq_timemgr_alarm_pause)) + endif + + enddo + + ! -------------------------------------------------------------------- + ! Set the timing run alarms, these alarms are synced to the driver + ! clock and determine when the component clocks are advanced. + ! We need an offset here of the driver timestep because of the + ! implementation. We are advancing the clock first and we want + ! components to run as soon as possible. Without the driver offset + ! the alarms would go off at the last possible timestep, not first. + ! In addition, we allow the user to set other offsets if desired + ! via namelist. tcraig, 10/2007 + ! -------------------------------------------------------------------- + + offset(seq_timemgr_nclock_drv) = 0 + offset(seq_timemgr_nclock_atm) = atm_cpl_offset + offset(seq_timemgr_nclock_lnd) = lnd_cpl_offset + offset(seq_timemgr_nclock_ocn) = ocn_cpl_offset + offset(seq_timemgr_nclock_ice) = ice_cpl_offset + offset(seq_timemgr_nclock_glc) = glc_cpl_offset + offset(seq_timemgr_nclock_rof) = rof_cpl_offset + offset(seq_timemgr_nclock_wav) = wav_cpl_offset + offset(seq_timemgr_nclock_esp) = esp_cpl_offset + + do n = 1,max_clocks + if (abs(offset(n)) > dtime(n)) then + write(logunit,*) subname,' ERROR: offset too large',n,dtime(n),offset(n) + call shr_sys_abort() + endif + + !--- this is the required driver timestep offset --- + offset(n) = offset(n) + dtime(seq_timemgr_nclock_drv) + + if (mod(offset(n),dtime(seq_timemgr_nclock_drv)) /= 0) then + write(logunit,*) subname,' ERROR: offset not multiple',n,dtime(seq_timemgr_nclock_drv),offset(n) + call shr_sys_abort() + endif + enddo + + ! Set component run alarms on driver clock + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_atm), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_atmrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_atm), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_atmrun)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_lnd), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_lndrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_lnd), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_lndrun)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_rof), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_rofrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_rof), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_rofrun)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_ice), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_icerun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_ice), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_icerun)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_wav), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_wavrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_wav), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_wavrun)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_glc), rc=rc ) + OffsetTime = CurrTime + TimeStep + call ESMF_TimeIntervalSet( TimeStep, s=-offset(seq_timemgr_nclock_drv), rc=rc ) + OffsetTime = OffsetTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_glcrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_glc), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_glcrun)) + if (glc_avg_period == seq_timemgr_optGLCCouplingPeriod) then + ! Create this alarm identically to the glcrun alarm (which is created above) + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_glcrun_avg), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_glc), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_glcrun_avg)) + else if (glc_avg_period == seq_timemgr_optYearly) then + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_glcrun_avg), & + option = seq_timemgr_optYearly, & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_glcrun_avg)) + else + call shr_sys_abort(subname//':: glc_avg_period can only be glc_coupling_period or yearly') + end if + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_ocn), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_ocnrun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_ocn), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_ocnrun)) + + ! --- this is the ocnrun alarm (there ^) offset by a -dtime of the driver + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_ocn), rc=rc ) + OffsetTime = CurrTime + TimeStep + call ESMF_TimeIntervalSet( TimeStep, s=-offset(seq_timemgr_nclock_drv), rc=rc ) + OffsetTime = OffsetTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_ocnnext), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_ocn), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_ocnnext)) + + call ESMF_TimeIntervalSet( TimeStep, s=offset(seq_timemgr_nclock_esp), rc=rc ) + OffsetTime = CurrTime + TimeStep + call seq_timemgr_alarmInit(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, & + EAlarm = SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_esprun), & + option = seq_timemgr_optNSeconds, & + opt_n = dtime(seq_timemgr_nclock_esp), & + RefTime = OffsetTime, & + alarmname = trim(seq_timemgr_alarm_esprun)) + +end subroutine seq_timemgr_clockInit + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_EClockGetData -- Get information from the clock +! +! !DESCRIPTION: +! +! Get various values from the clock. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_EClockGetData( EClock, curr_yr, curr_mon, curr_day, & + curr_ymd, curr_tod, prev_ymd, prev_tod, start_ymd, & + start_tod, StepNo, ref_ymd, ref_tod, & + stop_ymd, stop_tod, dtime, ECurrTime, alarmcount, & + curr_cday, next_cday, curr_time, prev_time, calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(IN) :: EClock ! Input clock object + integer(SHR_KIND_IN), intent(OUT), optional :: curr_yr ! Current year + integer(SHR_KIND_IN), intent(OUT), optional :: curr_mon ! Current month + integer(SHR_KIND_IN), intent(OUT), optional :: curr_day ! Current day in month + integer(SHR_KIND_IN), intent(OUT), optional :: curr_ymd ! Current date YYYYMMDD + integer(SHR_KIND_IN), intent(OUT), optional :: curr_tod ! Current time of day (s) + integer(SHR_KIND_IN), intent(OUT), optional :: prev_ymd ! Previous date YYYYMMDD + integer(SHR_KIND_IN), intent(OUT), optional :: prev_tod ! Previous time of day (s) + integer(SHR_KIND_IN), intent(OUT), optional :: start_ymd ! Starting date YYYYMMDD + integer(SHR_KIND_IN), intent(OUT), optional :: start_tod ! Starting time-of-day (s) + integer(SHR_KIND_IN), intent(OUT), optional :: StepNo ! Number of steps taken + integer(SHR_KIND_IN), intent(OUT), optional :: ref_ymd ! Reference date YYYYMMDD + integer(SHR_KIND_IN), intent(OUT), optional :: ref_tod ! Reference time-of-day (s) + integer(SHR_KIND_IN), intent(OUT), optional :: stop_ymd ! Stop date YYYYMMDD + integer(SHR_KIND_IN), intent(OUT), optional :: stop_tod ! Stop time-of-day (s) + integer(SHR_KIND_IN), intent(OUT), optional :: dtime ! Time-step (seconds) + integer(SHR_KIND_IN), intent(OUT), optional :: alarmcount ! Number of Valid Alarms + type(ESMF_Time), intent(OUT), optional :: ECurrTime ! Current ESMF time + real(SHR_KIND_R8) , intent(OUT), optional :: curr_cday ! current calendar day + real(SHR_KIND_R8) , intent(OUT), optional :: next_cday ! current calendar day + real(SHR_KIND_R8) , intent(OUT), optional :: curr_time ! time interval between current time + ! and reference date + real(SHR_KIND_R8) , intent(OUT), optional :: prev_time ! time interval between previous time + ! and reference date + character(len=*) , intent(OUT), optional :: calendar ! calendar type + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_EClockGetData) ' + type(ESMF_Time) :: CurrentTime ! Current time + type(ESMF_Time) :: PreviousTime ! Previous time + type(ESMF_Time) :: StartTime ! Start time + type(ESMF_Time) :: StopTime ! Stop time + type(ESMF_Time) :: RefTime ! Ref time + type(ESMF_TimeInterval) :: timeStep ! Clock, time-step + type(ESMF_TimeInterval) :: timediff ! Used to calculate curr_time + integer(SHR_KIND_IN) :: rc ! Return code + integer(SHR_KIND_I8) :: advSteps ! Number of time-steps that have advanced + integer(SHR_KIND_IN) :: yy, mm, dd, sec ! Return time values + integer(SHR_KIND_IN) :: ymd ! Date (YYYYMMDD) + integer(SHR_KIND_IN) :: tod ! time of day (sec) + integer(SHR_KIND_IN) :: ldtime ! local dtime + integer(SHR_KIND_IN) :: days ! number of whole days in time interval + integer(SHR_KIND_IN) :: seconds ! number of seconds in time interval + integer(SHR_KIND_IN) :: acount ! number of valid alarms + real(SHR_KIND_R8) :: doy, tmpdoy ! day of year + real(SHR_KIND_R8),parameter :: c1 = 1.0_SHR_KIND_R8 + + type(ESMF_Time) :: tmpTime ! tmp time, needed for next_cday + type(ESMF_TimeInterval) :: tmpDTime ! tmp time interval, needed for next_cday + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + if (present(calendar)) calendar = trim(seq_timemgr_calendar) + + call ESMF_ClockGet( EClock, currTime=CurrentTime, & + advanceCount=advSteps, prevTime=previousTime, TimeStep=timeStep, & + startTime=StartTime, stopTime=stopTime, refTime=RefTime, & + AlarmCount=acount, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGet" ) + + call ESMF_TimeGet( CurrentTime, yy=yy, mm=mm, dd=dd, s=sec, dayofyear_r8=doy, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_TimeGet" ) + call seq_timemgr_ETimeGet( CurrentTime, ymd=ymd, tod=tod ) + call ESMF_TimeIntervalGet( timeStep, s=ldtime, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_TimeIntervalGet" ) + + if ( present(curr_yr) ) curr_yr = yy + if ( present(curr_mon) ) curr_mon = mm + if ( present(curr_day) ) curr_day = dd + if ( present(curr_tod) ) curr_tod = tod + if ( present(curr_ymd) ) curr_ymd = ymd + if ( present(ECurrTime)) ECurrTime= CurrentTime + if ( present(StepNo) ) StepNo = advSteps + if ( present(dtime) ) dtime = ldtime + if ( present(curr_cday)) curr_cday = doy + if ( present(alarmcount)) alarmcount = acount + if ( present(next_cday)) then + call ESMF_TimeSet(tmpTime, yy=yy, mm=mm, dd=dd, s=tod, calendar=seq_timemgr_cal, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from TimeSet tmpTime") + call ESMF_TimeIntervalSet( tmpDTime, d=1, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from TimeIntSet tmpDTime") + tmpTime = tmpTime + tmpDTime + call ESMF_TimeGet(tmpTime, dayOfYear_r8=tmpdoy, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from TimeGet tmpdoy") + next_cday = tmpdoy + endif + + ! ---Current Time (the time interval between the current date and the reference date) --- + if ( present(curr_time)) then + timediff = CurrentTime - RefTime + call ESMF_TimeIntervalGet(timediff, d=days, s=seconds, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from TimeIntervalGet timediff") + curr_time = days + seconds/real(SecPerDay,SHR_KIND_R8) + end if + + ! ---Previous Time (the time interval between the previous date and the reference date) --- + if ( present(prev_time)) then + timediff = PreviousTime - RefTime + call ESMF_TimeIntervalGet(timediff, d=days, s=seconds, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from TimeIntervalGet timediff") + prev_time = days + seconds/real(SecPerDay,SHR_KIND_R8) + end if + + ! --- Previous time -------------------------------------------------------- + if ( present(prev_ymd) .or. present(prev_tod) )then + call seq_timemgr_ETimeGet( PreviousTime, ymd=ymd, tod=tod ) + if ( present(prev_ymd) ) prev_ymd = ymd + if ( present(prev_tod) ) prev_tod = tod + end if + + ! --- If want start date ----------------------------------------------- + if ( present(start_ymd) .or. present(start_tod) )then + call seq_timemgr_ETimeGet( StartTime, ymd=ymd, tod=tod ) + if ( present(start_ymd) ) start_ymd = ymd + if ( present(start_tod) ) start_tod = tod + end if + + ! --- If want stop date ----------------------------------------------- + if ( present(stop_ymd) .or. present(stop_tod) )then + call seq_timemgr_ETimeGet( stopTime, ymd=ymd, tod=tod ) + if ( present(stop_ymd) ) stop_ymd = ymd + if ( present(stop_tod) ) stop_tod = tod + end if + + ! --- If want ref date ----------------------------------------------- + if ( present(ref_ymd) .or. present(ref_tod) )then + call seq_timemgr_ETimeGet( RefTime, ymd=ymd, tod=tod ) + if ( present(ref_ymd) ) ref_ymd = ymd + if ( present(ref_tod) ) ref_tod = tod + end if + +end subroutine seq_timemgr_EClockGetData +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_clockAdvance -- Advance the syncclock +! +! !DESCRIPTION: +! +! Advance this clock +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_clockAdvance( SyncClock, force_stop, force_stop_ymd, force_stop_tod ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_timemgr_type), intent(INOUT) :: SyncClock ! Advancing clock + logical, optional, intent(in) :: force_stop ! force stop + integer, optional, intent(in) :: force_stop_ymd ! force stop ymd + integer, optional, intent(in) :: force_stop_tod ! force stop tod + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_clockAdvance) ' + integer :: n + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + integer :: rc ! Return code + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + ! --- set datestop alarm to force_stop alarm --- + + do n = 1,max_clocks + call seq_timemgr_alarmSetOff(SyncClock%ECP(n)%EClock) + if (present(force_stop) .and. present(force_stop_ymd) .and. present(force_stop_tod)) then + if (force_stop) then + if (n == 1 .and. seq_comm_iamroot(CPLID)) then + write(logunit,*) subname,'force stop at ',force_stop_ymd, force_stop_tod + endif + if (force_stop_ymd < 0 .or. force_stop_tod < 0) then + call shr_sys_abort(subname//': force_stop_ymd, force_stop_tod invalid') + endif + seq_timemgr_end_restart = .true. + call seq_timemgr_ETimeInit(NextAlarm, force_stop_ymd, force_stop_tod, "optDate") + CALL ESMF_AlarmSet( SyncClock%EAlarm(n,seq_timemgr_nalarm_datestop), & + name = trim(seq_timemgr_alarm_datestop), & + RingTime=NextAlarm, & + rc=rc ) + endif + endif + enddo + + ! --- advance driver clock and all driver alarms --- + + call ESMF_ClockAdvance( SyncClock%ECP(seq_timemgr_nclock_drv)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from drv ESMF_ClockAdvance") + + ! --- advance other clocks if driver component run alarm is ringing --- + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_atmrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_atm)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from atm ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_lndrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_lnd)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from lnd ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_rofrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_rof)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from rof ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_ocnrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_ocn)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from ocn ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_icerun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_ice)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from ice ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_glcrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_glc)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from glc ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_wavrun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_wav)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from wav ESMF_ClockAdvance") + endif + + if (ESMF_AlarmIsRinging(SyncClock%EAlarm(seq_timemgr_nclock_drv,seq_timemgr_nalarm_esprun))) then + call ESMF_ClockAdvance(SyncClock%ECP(seq_timemgr_nclock_esp)%EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, msg=subname//"Error from esp ESMF_ClockAdvance") + endif + + ! Special handling of ESP component if linked to pause cycles + if (seq_timemgr_esp_run_on_pause) then + ! We need to figure out if any pause clock is ringing + call seq_timemgr_alarmSetOff(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock,seq_timemgr_alarm_esprun) + if (seq_timemgr_alarmIsOn(SyncClock%ECP(seq_timemgr_pause_sig_index)%EClock,seq_timemgr_alarm_pause)) then + call seq_timemgr_alarmSetOn(SyncClock%ECP(seq_timemgr_nclock_drv)%EClock,seq_timemgr_alarm_esprun) + end if + end if + + ! Special handling of restart alarm if end_restart is .true. + if (seq_timemgr_end_restart) then + do n = 1,max_clocks + if (seq_timemgr_alarmIsOn(SyncClock%ECP(n)%EClock,seq_timemgr_alarm_stop) .or. & + seq_timemgr_alarmIsOn(SyncClock%ECP(n)%EClock,seq_timemgr_alarm_datestop)) then + call seq_timemgr_alarmSetOn(SyncClock%ECP(n)%EClock,seq_timemgr_alarm_restart) + endif + enddo + endif + +end subroutine seq_timemgr_clockAdvance + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_alarmInit -- Set an alarm +! +! !DESCRIPTION: +! +! Setup an alarm in a clock +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_alarmInit( EClock, EAlarm, option, opt_n, opt_ymd, opt_tod, RefTime, alarmname) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(INOUT) :: EClock ! clock + type(ESMF_Alarm) , intent(INOUT) :: EAlarm ! alarm + character(len=*) , intent(IN) :: option ! alarm option + integer(SHR_KIND_IN),optional, intent(IN) :: opt_n ! alarm freq + integer(SHR_KIND_IN),optional, intent(IN) :: opt_ymd ! alarm ymd + integer(SHR_KIND_IN),optional, intent(IN) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) ,optional, intent(IN) :: RefTime ! ref time + character(len=*) ,optional, intent(IN) :: alarmname ! alarm name + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_alarmInit): ' + integer :: rc ! Return code + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + integer :: nyy,nmm,ndd,nsec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + +!------------------------------------------------------------------------------- +! Notes: This is slightly screwed up because of the way the ESMF alarm +! initializes. The ringtime sent to AlarmCreate MUST be the next +! alarm time. If you send an arbitrary but proper ringtime from +! the past and the ring interval, the alarm will always go off on +! the next clock advance and this will cause serious problems. +! So, even if it makes sense to initialize an alarm with some +! reference time and the alarm interval, that reference time has +! to be advance forward to be >= the current time. In the logic +! below, we set an appropriate "NextAlarm" and then we make sure +! to advance it properly based on the ring interval. +!------------------------------------------------------------------------------- + + lalarmname = 'alarm_unknown' + if (present(alarmname)) then + lalarmname = trim(alarmname) + endif + + ltod = 0 + if (present(opt_tod)) then + ltod = opt_tod + endif + + lymd = -1 + if (present(opt_ymd)) then + lymd = opt_ymd + endif + + call ESMF_ClockGet(EClock, CurrTime=CurrTime, rc=rc) + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + + ! --- initial guess of next alarm, this will be updated below --- + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + call ESMF_TimeGet(CurrTime, yy=nyy, mm=nmm, dd=ndd, s=nsec, rc=rc ) + + update_nextalarm = .true. + + selectcase (trim(option)) + + case (seq_timemgr_optNONE) + !--- tcx seems we need an alarm interval or the alarm create fails, + !--- problem in esmf_wrf_timemgr? + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + update_nextalarm = .false. + + case (seq_timemgr_optNever) + !--- tcx seems we need an alarm interval or the alarm create fails, + !--- problem in esmf_wrf_timemgr? + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + update_nextalarm = .false. + + case (seq_timemgr_optDate) + !--- tcx seems we need an alarm interval or the alarm create fails, + !--- problem in esmf_wrf_timemgr? + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (.not. present(opt_ymd)) call shr_sys_abort(subname//trim(option)//' requires opt_ymd') + if (lymd < 0 .or. ltod < 0) then + call shr_sys_abort(subname//trim(option)//'opt_ymd, opt_tod invalid') + endif + call seq_timemgr_ETimeInit(NextAlarm, lymd, ltod, "optDate") + update_nextalarm = .false. + + case (seq_timemgr_optIfdays0) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (.not. present(opt_ymd)) call shr_sys_abort(subname//trim(option)//' requires opt_ymd') + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNSteps) + call ESMF_ClockGet(EClock, TimeStep=AlarmInterval, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNStep) + call ESMF_ClockGet(EClock, TimeStep=AlarmInterval, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNSeconds) + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNSecond) + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNMinutes) + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNMinute) + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNHours) + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNHour) + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n + + case (seq_timemgr_optNDays) + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=cdd, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNDay) + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=cdd, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNMonths) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNMonth) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optMonthly) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNYears) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optNYear) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + AlarmInterval = AlarmInterval * opt_n +! call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optYearly) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=seq_timemgr_cal, rc=rc ) + + case (seq_timemgr_optEnd) + call shr_sys_abort(subname//'deprecated option '//trim(option)) + + case default + call shr_sys_abort(subname//'unknown option '//trim(option)) + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- most options above. go back one alarminterval just to be careful + + if (update_nextalarm) then + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo + endif + + EAlarm = ESMF_AlarmCreate( name=lalarmname, clock=EClock, ringTime=NextAlarm, & + ringInterval=AlarmInterval, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmCreate" ) + +end subroutine seq_timemgr_AlarmInit + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_alarmGet -- Get information from the alarm +! +! !DESCRIPTION: +! +! Get various values from the alarm. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_alarmGet( EAlarm, next_ymd, next_tod, prev_ymd, prev_tod, & + IntSec, IntMon, IntYrs, name) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Alarm) , intent(INOUT) :: EAlarm ! Input Alarm object + integer(SHR_KIND_IN), intent(OUT), optional :: next_ymd ! alarm date yyyymmdd + integer(SHR_KIND_IN), intent(OUT), optional :: next_tod ! alarm tod sec + integer(SHR_KIND_IN), intent(OUT), optional :: prev_ymd ! alarm date yyyymmdd + integer(SHR_KIND_IN), intent(OUT), optional :: prev_tod ! alarm tod sec + integer(SHR_KIND_IN), intent(OUT), optional :: IntSec ! alarm int sec + integer(SHR_KIND_IN), intent(OUT), optional :: IntMon ! alarm int mon + integer(SHR_KIND_IN), intent(OUT), optional :: IntYrs ! alarm int yrs + character(len=*) , intent(OUT), optional :: name ! alarm name + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_alarmGet) ' + integer :: yy, mm, dd, sec ! Return time values + integer :: ymd ! Date (YYYYMMDD) + integer :: tod ! time of day (sec) + integer :: rc ! error code + type(ESMF_TimeInterval) :: alarmInterval ! Alarm interval + type(ESMF_Time) :: ringTime ! Next alarm ring time + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (present(name)) then + call ESMF_AlarmGet( EAlarm, name=name, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmGet name" ) + endif + + call ESMF_AlarmGet( EAlarm, RingTime=RingTime, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmGet RingTime" ) + call seq_timemgr_ETimeGet( RingTime, ymd=ymd, tod=tod) + if ( present(next_ymd) ) next_ymd = ymd + if ( present(next_tod) ) next_tod = tod + + call ESMF_AlarmGet( EAlarm, PrevRingTime=RingTime, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmGet PrevRingTime") + call seq_timemgr_ETimeGet( RingTime, ymd=ymd, tod=tod) + if ( present(prev_ymd) ) prev_ymd = ymd + if ( present(prev_tod) ) prev_tod = tod + + yy = 0 + mm = 0 + dd = 0 + sec = 0 + call ESMF_AlarmGet( EAlarm, RingInterval=AlarmInterval, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmGet RingInterval") + call ESMF_TimeIntervalGet( alarmInterval, yy=yy, mm=mm, d=dd, s=sec, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_TimeIntervalGet" ) + sec = sec + dd*(SecPerDay) + + ! --- If want restart next interval information ------------------------- + if ( present(IntSec) ) IntSec = sec + if ( present(IntMon) ) IntMon = mm + if ( present(IntYrs) ) IntYrs = yy + +end subroutine seq_timemgr_alarmGet +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_alarmSetOn -- turn alarm on +! +! !DESCRIPTION: +! +! turn alarm on +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_AlarmSetOn( EClock, alarmname) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(INOUT) :: EClock ! clock/alarm + character(len=*), intent(IN), optional :: alarmname ! alarmname + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_alarmSetOn) ' + character(len=*), parameter :: xalarm = 'unset' + integer :: n + integer :: rc + logical :: found + logical :: set + character(len=64) :: name + type(ESMF_Alarm),pointer :: EAlarm_list(:) + integer(SHR_KIND_IN) :: AlarmCount ! Number of valid alarms + +!------------------------------------------------------------------------------- +! Notes: The Alarm_list is returned and only a subset of the alarms may +! be initialized. In the esmf_wrf_timemgr, numalarms is not used internally, +! and the alarm pointer is valid if it's associated. If it's not associated +! the AlarmGet calls will generally return an error code. What we really +! want is to ignore the unset alarms. So below, we have to kind of kludge +! this up. We set name=xalarm, a special value, before the AlarmGet call so +! if Alarm_list(n) is not associated, the name will remain the value of +! xalarm. Then we check whether it's a valid alarm by first checking +! the name vs xalarm. If name is not xalarm, then it must be a valid alarm +! and we either set found to true if we are setting all alarms or we compare +! the name returned to the alarm name we're looking for and only set found +! to true if the names match. +!------------------------------------------------------------------------------- + + set = .false. + + call seq_timemgr_EClockGetData(EClock, AlarmCount=AlarmCount) +#ifdef USE_ESMF_LIB + allocate(EAlarm_list(AlarmCount)) + call ESMF_ClockGetAlarmList(EClock, alarmListFlag=ESMF_ALARMLIST_ALL, & + alarmList=EAlarm_list, alarmCount=AlarmCount, rc=rc) +#else + call ESMF_ClockGetAlarmList(EClock, EAlarm_list, rc=rc) +#endif + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGetAlarmList" ) + do n = 1,AlarmCount + found = .false. + if (present(alarmname)) then + call ESMF_AlarmGet(EAlarm_list(n), name=name) + if (trim(name) == trim(alarmname)) found = .true. + else + found = .true. + endif + if (found) then + set = .true. + call ESMF_AlarmRingerOn( EAlarm_list(n), rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmRingerOn" ) + endif + enddo + + if (present(alarmname) .and. .not. set) then + write(logunit,*) subname,' ERROR in alarmname ',trim(alarmname) + call shr_sys_abort() + endif +#ifdef USE_ESMF_LIB + deallocate(EAlarm_list) +#endif + +end subroutine seq_timemgr_AlarmSetOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_alarmSetOff -- turn alarm off +! +! !DESCRIPTION: +! +! turn alarm off +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_AlarmSetOff( EClock, alarmname) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(INOUT) :: EClock ! clock/alarm + character(len=*), intent(IN), optional :: alarmname ! alarmname + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_alarmSetOff) ' + character(len=*), parameter :: xalarm = 'unset' + integer :: n + integer :: rc + logical :: found + logical :: set + character(len=64) :: name + type(ESMF_Alarm),pointer :: EAlarm_list(:) + integer(SHR_KIND_IN) :: AlarmCount ! Number of valid alarms + +!------------------------------------------------------------------------------- +! Notes: The Alarm_list is returned and only a subset of the alarms may +! be initialized. In the esmf_wrf_timemgr, numalarms is not used internally, +! and the alarm pointer is valid if it's associated. If it's not associated +! the AlarmGet calls will generally return an error code. What we really +! want is to ignore the unset alarms. So below, we have to kind of kludge +! this up. We set name=xalarm, a special value, before the AlarmGet call so +! if Alarm_list(n) is not associated, the name will remain the value of +! xalarm. Then we check whether it's a valid alarm by first checking +! the name vs xalarm. If name is not xalarm, then it must be a valid alarm +! and we either set found to true if we are setting all alarms or we compare +! the name returned to the alarm name we're looking for and only set found +! to true if the names match. +!------------------------------------------------------------------------------- + + set = .false. + + call seq_timemgr_EClockGetData(EClock, AlarmCount=AlarmCount) +#ifdef USE_ESMF_LIB + allocate(EAlarm_list(AlarmCount)) + call ESMF_ClockGetAlarmList(EClock, alarmListFlag=ESMF_ALARMLIST_ALL, & + alarmList=EAlarm_list, alarmCount=AlarmCount, rc=rc) +#else + call ESMF_ClockGetAlarmList(EClock, EAlarm_list, rc=rc) +#endif + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGetAlarmList" ) + do n = 1,AlarmCount + found = .false. + if (present(alarmname)) then + call ESMF_AlarmGet(EAlarm_list(n), name=name) + if (trim(name) == trim(alarmname)) found = .true. + else + found = .true. + endif + if (found) then + set = .true. + call ESMF_AlarmRingerOff( EAlarm_list(n), rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmRingerOff" ) + endif + enddo + + if (present(alarmname) .and. .not. set) then + write(logunit,*) subname,' ERROR in alarmname ',trim(alarmname) + call shr_sys_abort() + endif +#ifdef USE_ESMF_LIB + deallocate(EAlarm_list) +#endif + +end subroutine seq_timemgr_AlarmSetOff + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_alarmIsOn -- check if an alarm is ringing +! +! !DESCRIPTION: +! +! check if an alarm is ringing +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_alarmIsOn( EClock, alarmname) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(IN) :: EClock ! clock/alarm + character(len=*), intent(IN) :: alarmname ! which alarm + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_alarmIsOn) ' + character(len=*), parameter :: xalarm = 'unset' + integer :: n + integer :: rc + logical :: found + character(len=64) :: name + type(ESMF_Time) :: ETime1, ETime2 + type(ESMF_Alarm),pointer :: EAlarm_list(:) + integer(SHR_KIND_IN) :: AlarmCount ! Number of valid alarms + +!------------------------------------------------------------------------------- +! Notes: Because of the esmf_wrf_timemgr implementation with regards to +! valid alarms in the alarm_list, we initialize name to xalarm before +! querying the alarm name, and if the alarm is not valid, name will not +! be updated and we can tell that the alarm is not valid and we should +! just ignore it. +! Use found to verify alarm was valid. If not, abort +!------------------------------------------------------------------------------- + + seq_timemgr_alarmIsOn = .false. + found = .false. + + call seq_timemgr_EClockGetData(EClock, AlarmCount=AlarmCount) +#ifdef USE_ESMF_LIB + allocate(EAlarm_list(AlarmCount)) + call ESMF_ClockGetAlarmList(EClock, alarmListFlag=ESMF_ALARMLIST_ALL, & + alarmList=EAlarm_list, alarmCount=AlarmCount, rc=rc) +#else + call ESMF_ClockGetAlarmList(EClock, EAlarm_list, rc=rc) +#endif + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGetAlarmList" ) + do n = 1,AlarmCount + name = trim(xalarm) + call ESMF_AlarmGet(EAlarm_list(n), name=name) + if (trim(name) == trim(alarmname)) then + found = .true. + seq_timemgr_alarmIsOn = ESMF_AlarmIsRinging(alarm=EAlarm_list(n),rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname// & + "Error from ESMF_AlarmIsRinging" ) + ! --- make sure the datestop will always stop with dates >= stop_date + if (trim(alarmname) == trim(seq_timemgr_alarm_datestop)) then + call ESMF_ClockGet(EClock, CurrTime = ETime1, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGet CurrTime" ) + call ESMF_AlarmGet(EAlarm_list(n), RingTime = ETime2, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_AlarmGet RingTime" ) + if (ETime1 >= ETime2) seq_timemgr_alarmIsOn = .true. + endif + endif + enddo + + if (.not.found) then + write(logunit,*) subname//': ERROR alarm not valid for EClock '//trim(alarmname) + call shr_sys_abort( subname//'ERROR: alarm invalid '//trim(alarmname) ) + endif +#ifdef USE_ESMF_LIB + deallocate(EAlarm_list) +#endif + +end function seq_timemgr_alarmIsOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_restartAlarmIsOn -- check if an alarm is ringing +! +! !DESCRIPTION: +! +! check if an alarm is ringing +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_restartAlarmIsOn( EClock) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(IN) :: EClock ! clock/alarm + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_restartAlarmIsOn) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + seq_timemgr_restartAlarmIsOn = & + seq_timemgr_alarmIsOn(EClock, alarmname=seq_timemgr_alarm_restart) + +end function seq_timemgr_restartAlarmIsOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_stopAlarmIsOn -- check if an alarm is ringing +! +! !DESCRIPTION: +! +! check if an alarm is ringing +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_stopAlarmIsOn( EClock) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(IN) :: EClock ! clock/alarm + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_stopAlarmIsOn) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + seq_timemgr_stopAlarmIsOn = & + seq_timemgr_alarmIsOn(EClock, alarmname=seq_timemgr_alarm_stop) + +end function seq_timemgr_stopAlarmIsOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_historyAlarmIsOn -- check if an alarm is ringing +! +! !DESCRIPTION: +! +! check if an alarm is ringing +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_historyAlarmIsOn( EClock) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(IN) :: EClock ! clock/alarm + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_historyAlarmIsOn) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + seq_timemgr_historyAlarmIsOn = & + seq_timemgr_alarmIsOn(EClock, alarmname=seq_timemgr_alarm_history) + +end function seq_timemgr_historyAlarmIsOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_pauseAlarmIsOn -- check if an alarm is ringing +! +! !DESCRIPTION: +! +! check if an alarm is ringing +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_pauseAlarmIsOn( EClock) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(IN) :: EClock ! clock/alarm + +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_pauseAlarmIsOn) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + seq_timemgr_pauseAlarmIsOn = & + seq_timemgr_alarmIsOn(EClock, alarmname=seq_timemgr_alarm_pause) + + end function seq_timemgr_pauseAlarmIsOn + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_pause_active -- Is pause/resume active this run? +! +! !DESCRIPTION: +! +! Return .true. if any component is configured for pause/resume +! +! !INTERFACE: ------------------------------------------------------------------ + + logical function seq_timemgr_pause_active() + +! !INPUT/OUTPUT PARAMETERS: + +!EOP + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + seq_timemgr_pause_active = ANY(pause_active) + + end function seq_timemgr_pause_active + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_pause_component_index -- return an index for a component +! +! !DESCRIPTION: +! +! Look up a component's internal index for faster processing +! +! !INTERFACE: ------------------------------------------------------------------ + + integer function seq_timemgr_pause_component_index(component_name) + +! !INPUT/OUTPUT PARAMETERS: + + character(len=*), intent(IN) :: component_name + +!EOP + + !----- local ----- + integer :: ind + character(len=*), parameter :: subname = '(seq_timemgr_pause_component_index) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + seq_timemgr_pause_component_index = 0 + do ind = 1, max_clocks + if (trim(component_name) == trim(seq_timemgr_clocks(ind))) then + seq_timemgr_pause_component_index = ind + exit + end if + end do + if (seq_timemgr_pause_component_index < 1) then + if (trim(component_name) == 'cpl') then + seq_timemgr_pause_component_index = seq_timemgr_nclock_drv + end if + end if + if (seq_timemgr_pause_component_index < 1) then + call shr_sys_abort(subname//': No index for component '//trim(component_name)) + end if + + end function seq_timemgr_pause_component_index + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_pause_component_active -- Check if component paused +! +! !DESCRIPTION: +! +! Return .true. if component is active in driver pause +! +! !INTERFACE: ------------------------------------------------------------------ + + logical function seq_timemgr_pause_component_active(component_index) + +! !INPUT/OUTPUT PARAMETERS: + + integer, intent(IN) :: component_index + +!EOP + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_pause_component_active) ' + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ((component_index < 1) .or. (component_index > max_clocks)) then + call shr_sys_abort(subname//': component_index out of range') + end if + seq_timemgr_pause_component_active = pause_active(component_index) + + end function seq_timemgr_pause_component_active + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_ETimeInit -- Create ESMF_Time object based on YMD values +! +! !DESCRIPTION: +! +! Create the ESMF_Time object corresponding to the given input time, given in +! YMD (Year Month Day) and TOD (Time-of-day) format. +! Set the time by an integer as YYYYMMDD and integer seconds in the day +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_ETimeInit( ETime, ymd, tod, desc ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Time) , intent(inout) :: ETime ! Time + integer , intent(in) :: ymd ! Year, month, day YYYYMMDD + integer , intent(in), optional :: tod ! Time of day in seconds + character(len=*), intent(in), optional :: desc ! Description of time to set + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_ETimeInit) ' + integer :: yr, mon, day ! Year, month, day as integers + integer :: ltod ! local tod + character(SHR_KIND_CL) :: ldesc ! local desc + integer :: rc ! return code + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + ltod = 0 + if (present(tod)) then + ltod = tod + endif + + ldesc = '' + if (present(desc)) then + ldesc = desc + endif + + if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then + write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & + 'time-of-day out of bounds', ymd, ltod + call shr_sys_abort( subname//'ERROR: Bad input' ) + end if + + call shr_cal_date2ymd(ymd,yr,mon,day) + + call ESMF_TimeSet( ETime, yy=yr, mm=mon, dd=day, s=ltod, & + calendar=seq_timemgr_cal, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, subname//': error return from '// & + 'ESMF_TimeSet: setting '//trim(ldesc)) + +end subroutine seq_timemgr_ETimeInit + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_ETimeGet -- Get the date in YYYYMMDD from from ESMF Time +! +! !DESCRIPTION: +! +! Get the date in YYYYMMDD format from a ESMF time object. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_ETimeGet( ETime, offset, ymd, tod ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Time), intent(IN) :: ETime ! Input ESMF time + integer, optional, intent(IN) :: offset ! Offset from input time (sec) + integer, optional, intent(OUT) :: ymd ! date of day + integer, optional, intent(OUT) :: tod ! Time of day + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_ETimeGet) ' + type(ESMF_Time) :: ETimeAdd ! ESMF time + offset + type(ESMF_TimeInterval) :: ETimeOff ! ESMF offset time-interval + integer :: year ! Year + integer :: month ! Month + integer :: day ! Day in month + integer :: sec ! Day in month + integer :: rc ! Return code + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + ETimeAdd = ETime + if ( present(offset) )then + if ( offset > 0 )then + call ESMF_TimeIntervalSet( ETimeOff, s=offset, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname// & + ": Error from ESMF_TimeIntervalSet" ) + ETimeAdd = ETime + ETimeOff + else if ( offset < 0 )then + call ESMF_TimeIntervalSet( ETimeOff, s=-offset, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname// & + ": Error from ESMF_TimeIntervalSet" ) + ETimeAdd = ETime - ETimeOff + end if + end if + + call ESMF_TimeGet( ETimeAdd, yy=year, mm=month, dd=day, s=sec, rc=rc ) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname// & + ": Error from ESMF_TimeGet" ) + + ! shr_cal has restrictions and then "stops", so override that + + if ( present(ymd) ) then + call shr_cal_ymd2date(year,month,day,ymd) + endif + if ( present(tod) ) then + tod = sec + endif + +end subroutine seq_timemgr_ETimeGet + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_EClockInit -- Initialize the ESMF clock in the shared clock +! +! !DESCRIPTION: +! +! Private method: +! +! Setup the ESMF clock inside the wrapped CCSM clock +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_EClockInit( TimeStep, StartTime, RefTime, CurrTime, EClock ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_TimeInterval), intent(IN) :: TimeStep ! Time-step of clock + type(ESMF_Time) , intent(IN) :: StartTime ! Start time + type(ESMF_Time) , intent(IN) :: RefTime ! Reference time + type(ESMF_Time) , intent(IN) :: CurrTime ! Current time + type(ESMF_Clock) , intent(OUT) :: EClock ! Output ESMF clock + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_EClockInit) ' + integer :: rc ! ESMF return code + character(len=SHR_KIND_CL) :: description ! Description of this clock + type(ESMF_Time) :: clocktime ! Current time + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + description = 'CCSM shared Time-manager clock' + + ! ------ Create ESMF Clock with input characteristics ------------------- + ! --- NOTE: StopTime is required in interface but not used, so use ----- + ! --- something arbitrary. Stop handled via alarm ----- + + call seq_timemgr_ETimeInit(clocktime, 99990101, 0, "artificial stop date") + + EClock = ESMF_ClockCreate(name=trim(description), & + TimeStep=TimeStep, startTime=StartTime, & + refTime=RefTime, stopTime=clocktime, rc=rc) + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//': Error from ESMF_ClockCreate') + + ! ------ Advance clock to the current time (in case of a restart) ------- + call ESMF_ClockGet(EClock, currTime=clocktime, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, subname//': Error from ESMF_ClockGet') + do while( clocktime < CurrTime) + call ESMF_ClockAdvance( EClock, rc=rc ) + call seq_timemgr_ESMFCodeCheck(rc, subname//': Error from ESMF_ClockAdvance') + call ESMF_ClockGet( EClock, currTime=clocktime ) + call seq_timemgr_ESMFCodeCheck(rc, subname//': Error from ESMF_ClockGet') + end do + + if (clocktime /= CurrTime) then + if (loglevel > 0) write(logunit,*) trim(subname), & + ' : WARNING clocktime and currtime inconsistent' + endif + +end subroutine seq_timemgr_EClockInit + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_EClockDateInSync -- Check that input date in sync with clock +! +! !DESCRIPTION: +! +! Check that the given input date/time is in sync with clock time +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function seq_timemgr_EClockDateInSync( EClock, ymd, tod, prev) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), intent(IN) :: Eclock ! Input clock to compare + integer, intent(IN) :: ymd ! Date (YYYYMMDD) + integer, intent(IN) :: tod ! Time of day (sec) + logical, optional,intent(IN) :: prev ! If should get previous time + + !----- local ----- + character(len=*), parameter :: subname = "(seq_timemgr_EClockDateInSync) " + type(ESMF_Time) :: ETime + integer :: ymd1 ! Date (YYYYMMDD) + integer :: tod1 ! Time of day + logical :: previous ! If need to get previous time for comparison + integer :: rc ! error code + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + previous = .false. + if ( present(prev) )then + previous = prev + end if + + if (previous )then + call ESMF_ClockGet( EClock, prevTime=ETime, rc=rc) + else + call ESMF_ClockGet( EClock, currTime=ETime, rc=rc) + end if + call seq_timemgr_ETimeGet( ETime, ymd=ymd1, tod=tod1 ) + + ! --- If current dates agree return true -- else false + + if ( (ymd == ymd1) .and. (tod == tod1) )then + seq_timemgr_EClockDateInSync = .true. + else + seq_timemgr_EClockDateInSync = .false. + end if + +end function seq_timemgr_EClockDateInSync + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_clockPrint -- Print clock information out +! +! !DESCRIPTION: +! +! Print clock information out. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_clockPrint( SyncClock ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(seq_timemgr_type), intent(in) :: SyncClock ! Input clock to print + + character(len=*), parameter :: subname = "(seq_timemgr_clockPrint) " + integer(SHR_KIND_IN) :: m,n + integer(SHR_KIND_IN) :: curr_ymd ! Current date YYYYMMDD + integer(SHR_KIND_IN) :: curr_tod ! Current time of day (s) + integer(SHR_KIND_IN) :: StepNo ! Number of steps taken + integer(SHR_KIND_IN) :: start_ymd ! Starting date YYYYMMDD + integer(SHR_KIND_IN) :: start_tod ! Starting time-of-day (s) + integer(SHR_KIND_IN) :: stop_ymd ! Stop date YYYYMMDD + integer(SHR_KIND_IN) :: stop_tod ! Stop time-of-day (s) + integer(SHR_KIND_IN) :: ref_ymd ! Reference date YYYYMMDD + integer(SHR_KIND_IN) :: ref_tod ! Reference time-of-day (s) + integer(SHR_KIND_IN) :: DTime ! Time-step (seconds) + integer(SHR_KIND_IN) :: prev_ymd ! Prev restart alarm date (YYYYMMDD) + integer(SHR_KIND_IN) :: prev_tod ! Prev restart alarm time-of-day (sec) + integer(SHR_KIND_IN) :: next_ymd ! Next restart alarm date (YYYYMMDD) + integer(SHR_KIND_IN) :: next_tod ! Next restart alarm time-of-day (sec) + integer(SHR_KIND_IN) :: IntSec ! Alarm interval for seconds + integer(SHR_KIND_IN) :: IntMon ! Alarm interval for months + integer(SHR_KIND_IN) :: IntYrs ! Alarm interval for years + integer(SHR_KIND_IN) :: AlarmCount ! Number of valid alarms + character(len=64) :: alarmname ! Alarm name + character(len=*), parameter :: xalarm = 'unset' + type(ESMF_Alarm),pointer :: EAlarm_list(:) ! EAlarm list associated with EClock + integer(SHR_KIND_IN) :: rc ! error code + + character(len=*), parameter :: F06 = "(2A,L3)" + character(len=*), parameter :: F07 = "(3A)" + character(len=*), parameter :: F08 = "(2A,I8.8,3x,I5.5)" + character(len=*), parameter :: F09 = "(2A,2I8,I12)" + character(len=*), parameter :: F10 = "(2A,I2,2x,A)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (loglevel <= 0) return + + write(logunit,F07) subname,'calendar = ', trim(seq_timemgr_calendar) + write(logunit,F06) subname,'end_restart = ', seq_timemgr_end_restart + write(logunit,F07) '' + + do n = 1,max_clocks + call seq_timemgr_EClockGetData( SyncClock%ECP(n)%EClock, curr_ymd=curr_ymd, & + curr_tod=curr_tod, start_ymd=start_ymd, & + start_tod=start_tod, StepNo=StepNo, & + ref_ymd=ref_ymd, ref_tod=ref_tod, & + stop_ymd=stop_ymd, stop_tod=stop_tod, & + dtime = dtime, alarmcount=AlarmCount) +#ifdef USE_ESMF_LIB + allocate(EAlarm_list(AlarmCount)) + call ESMF_ClockGetAlarmList(SyncClock%ECP(n)%EClock, alarmListFlag=ESMF_ALARMLIST_ALL, & + alarmList=EAlarm_list, alarmCount=AlarmCount, rc=rc) +#else + call ESMF_ClockGetAlarmList(SyncClock%ECP(n)%EClock, EAlarm_list, rc=rc) +#endif + call seq_timemgr_ESMFCodeCheck( rc, msg=subname//"Error from ESMF_ClockGetAlarmList" ) + + write(logunit,F09) subname,"Clock = "//seq_timemgr_clocks(n),n + write(logunit,F08) subname," Start Time = ", start_ymd, start_tod + write(logunit,F08) subname," Curr Time = ", curr_ymd, curr_tod + write(logunit,F08) subname," Ref Time = ", ref_ymd, ref_tod + write(logunit,F08) subname," Stop Time = ", stop_ymd, stop_tod + write(logunit,F09) subname," Step number = ", StepNo + write(logunit,F09) subname," Dtime = ", DTime + + do m = 1,alarmCount + call seq_timemgr_alarmGet( EAlarm_list(m), & + next_ymd=next_ymd, next_tod=next_tod, prev_ymd=prev_ymd, prev_tod=prev_tod, & + IntSec=IntSec, IntMon=IntMon, IntYrs=IntYrs, name=alarmname ) + write(logunit,F10) subname," Alarm = ",m,trim(alarmname) + write(logunit,F08) subname," Prev Time = ", prev_ymd,prev_tod + write(logunit,F08) subname," Next Time = ", next_ymd,next_tod + write(logunit,F09) subname," Intervl yms = ", IntYrs,IntMon,IntSec + enddo + + write(logunit,*) '' +#ifdef USE_ESMF_LIB + deallocate(EAlarm_list) +#endif + enddo + +end subroutine seq_timemgr_clockPrint + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_ESMFDebug -- Print ESMF stuff for debugging +! +! !DESCRIPTION: +! +! Print ESMF stuff for debugging +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_ESMFDebug( EClock, ETime, ETimeInterval, istring ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock), optional, intent(in) :: EClock ! ESMF Clock + type(ESMF_Time) , optional, intent(inout) :: ETime ! ESMF Time + type(ESMF_TimeInterval), optional, intent(inout) :: ETimeInterval ! ESMF Time Interval + character(len=*), optional, intent(in) :: istring + + !----- local ----- + character(len=*), parameter :: subname = '(seq_timemgr_ESMFDebug) ' + character(len=128) :: timestring + integer :: yy,mm,dd,s ! ymds + type(ESMF_Time) :: LTime + type(ESMF_TimeInterval) :: LTimeInterval + integer(SHR_KIND_I8) :: LStep + integer :: rc ! return code + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (present(ETime)) then + write(logunit,*) subname,' ETime ',trim(istring) + call ESMF_TimeGet(ETime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'ymds=',yy,mm,dd,s,trim(timestring) + endif + + if (present(ETimeInterval)) then + write(logunit,*) subname,' ETimeInterval ',trim(istring) + call ESMF_TimeIntervalGet(ETimeInterval, yy=yy,mm=mm,d=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'ymds=',yy,mm,dd,s,trim(timestring) + endif + + if (present(EClock)) then + write(logunit,*) subname,' EClock ',trim(istring) + call ESMF_ClockGet( EClock, StartTime=LTime ) + call ESMF_TimeGet(LTime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'start ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, CurrTime=LTime ) + call ESMF_TimeGet(LTime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'curr ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, StopTime=LTime ) + call ESMF_TimeGet(LTime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'stop ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, PrevTime=LTime ) + call ESMF_TimeGet(LTime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'prev ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, RefTime=LTime ) + call ESMF_TimeGet(LTime, yy=yy,mm=mm,dd=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'ref ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, TimeStep=LTimeInterval ) + call ESMF_TimeIntervalGet(LTimeInterval, yy=yy,mm=mm,d=dd,s=s,timestring=timestring,rc=rc) + write(logunit,*) subname,rc,'tint ymds=',yy,mm,dd,s,trim(timestring) + call ESMF_ClockGet( EClock, AdvanceCount=LStep ) + write(logunit,*) subname,rc,'advcnt =',LStep + endif + +end subroutine seq_timemgr_ESMFDebug + +!=============================================================================== +!=============================================================================== +! !IROUTINE: seq_timemgr_ESMFCodeCheck -- Check return-code from ESMF -- abort if not +! +! !DESCRIPTION: +! +! Check ESMF return code and abort if not successful. +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine seq_timemgr_ESMFCodeCheck( rc, msg ) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer, intent(in) :: rc ! return code from ESMF + character(len=*),optional,intent(in) :: msg ! error message + + character(len=*),parameter :: subname = 'seq_timemgr_ESMFCodeCheck' +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ( rc == ESMF_SUCCESS ) return + if ( present(msg)) then + write(logunit,*) trim(subname),' error= ',rc,trim(msg) + else + write(logunit,*) trim(subname),' error= ',rc + endif + call shr_sys_flush(logunit) + call shr_sys_abort(trim(subname)) + +end subroutine seq_timemgr_ESMFCodeCheck + +!=============================================================================== +!=============================================================================== + +end module seq_timemgr_mod diff --git a/driver-mct/shr/shr_carma_mod.F90 b/driver-mct/shr/shr_carma_mod.F90 new file mode 100644 index 000000000000..d06d783d747e --- /dev/null +++ b/driver-mct/shr/shr_carma_mod.F90 @@ -0,0 +1,70 @@ +!================================================================================ +! This reads the carma_inparm namelist in drv_flds_in and makes the relavent +! information available to CAM, CLM, and driver. The driver sets up CLM to CAM +! communication for the VOC flux fields. CLM needs to know what specific VOC +! fluxes need to be passed to the coupler and how to assimble the fluxes. +! CAM needs to know what specific VOC fluxes to expect from CLM. +! +! Mariana Vertenstein -- 24 Sep 2012 +!================================================================================ +module shr_carma_mod + + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : CL => SHR_KIND_CL, CX => SHR_KIND_CX, CS => SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : loglev => shr_log_Level + use shr_log_mod, only : logunit => shr_log_Unit + + implicit none + save + private + + public :: shr_carma_readnl ! reads carma_inparm namelist + +contains + + !------------------------------------------------------------------------- + ! This reads the carma_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + !------------------------------------------------------------------------- + subroutine shr_carma_readnl( NLFileName, carma_fields ) + + use shr_nl_mod, only : shr_nl_find_group_name + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + + character(len=*), intent(in) :: NLFileName + character(len=CX), intent(out) :: carma_fields + + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + character(*),parameter :: F00 = "('(shr_carma_readnl) ',2a)" + + namelist /carma_inparm/ carma_fields + + carma_fields = ' ' + + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + unitn = shr_file_getUnit() + open( unitn, file=trim(NLFilename), status='old' ) + if ( loglev > 0 ) write(logunit,F00) & + 'Read in carma_inparm namelist from: ', trim(NLFilename) + + call shr_nl_find_group_name(unitn, 'carma_inparm', status=ierr) + ! If ierr /= 0, no namelist present. + + if (ierr == 0) then + read(unitn, carma_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of carma_inparm namelist in shr_carma_readnl' ) + endif + end if + + close( unitn ) + call shr_file_freeUnit( unitn ) + end if + + end subroutine shr_carma_readnl + +endmodule shr_carma_mod diff --git a/driver-mct/shr/shr_expr_parser_mod.F90 b/driver-mct/shr/shr_expr_parser_mod.F90 new file mode 100644 index 000000000000..f37a4ac3c0be --- /dev/null +++ b/driver-mct/shr/shr_expr_parser_mod.F90 @@ -0,0 +1,185 @@ +!============================================================================= +! expression parser utility -- +! for parsing simple linear mathematical expressions of the form +! X = a*Y + b*Z + ... +! +!============================================================================= +module shr_expr_parser_mod + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : cx => shr_kind_cx + + implicit none + private + + public :: shr_exp_parse ! parses simple strings which contain expressions + public :: shr_exp_item_t ! user defined type which contains an expression component + public :: shr_exp_list_destroy ! destroy the linked list returned by shr_exp_parse + + ! contains componets of expression + type shr_exp_item_t + character(len=64) :: name + character(len=64),pointer :: vars(:) => null() + real(r8) ,pointer :: coeffs(:) => null() + integer :: n_terms = 0 + type(shr_exp_item_t), pointer :: next_item => null() + end type shr_exp_item_t + +contains + + ! ----------------------------------------------------------------- + ! parses expressions provided in array of strings + ! ----------------------------------------------------------------- + function shr_exp_parse( exp_array, nitems ) result(exp_items_list) + + character(len=*), intent(in) :: exp_array(:) ! contains a expressions + integer, optional, intent(out) :: nitems ! number of expressions parsed + type(shr_exp_item_t), pointer :: exp_items_list ! linked list of items returned + + integer :: i,j, jj, nmax, nterms, n_exp_items + character(len=cx) :: tmp_str + type(shr_exp_item_t), pointer :: exp_item, list_item + + nullify( exp_items_list ) + nullify( exp_item ) + nullify( list_item ) + + n_exp_items = 0 + nmax = size( exp_array ) + + do i = 1,nmax + if (len_trim(exp_array(i))>0) then + + j = scan( exp_array(i), '=' ) + + if ( j>0 ) then + + n_exp_items = n_exp_items + 1 + + allocate( exp_item ) + exp_item%n_terms = 0 + exp_item%name = trim(adjustl(exp_array(i)(:j-1))) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + nterms = 1 + jj = scan( tmp_str, '+' ) + do while(jj>0) + nterms = nterms + 1 + tmp_str = tmp_str(jj+1:) + jj = scan( tmp_str, '+' ) + enddo + + allocate( exp_item%vars(nterms) ) + allocate( exp_item%coeffs(nterms) ) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + j = scan( tmp_str, '+' ) + + if (j>0) then + call set_coefvar( tmp_str(:j-1), exp_item ) + tmp_str = tmp_str(j-1:) + else + call set_coefvar( tmp_str, exp_item ) + endif + + else + + tmp_str = trim(adjustl(exp_array(i))) ! assumed to begin with '+' + + endif + + ! at this point tmp_str begins with '+' + j = scan( tmp_str, '+' ) + + if (j>0) then + + ! remove the leading + ... + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + do while(j>0) + + call set_coefvar( tmp_str(:j-1), exp_item ) + + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + enddo + + call set_coefvar( tmp_str, exp_item ) + + endif + + + if (associated(exp_item)) then + if (associated(exp_items_list)) then + list_item => exp_items_list + do while(associated(list_item%next_item)) + list_item => list_item%next_item + enddo + list_item%next_item => exp_item + else + exp_items_list => exp_item + endif + endif + + endif + enddo + + if ( present(nitems) ) then + nitems = n_exp_items + endif + + end function shr_exp_parse + + ! ----------------------------------------------------------------- + ! deallocates memory occupied by linked list + ! ----------------------------------------------------------------- + subroutine shr_exp_list_destroy( list ) + type(shr_exp_item_t), pointer, intent(inout) :: list + + type(shr_exp_item_t), pointer :: item, next + + item => list + do while(associated(item)) + next => item%next_item + if (associated(item%vars)) then + deallocate(item%vars) + nullify(item%vars) + deallocate(item%coeffs) + nullify(item%coeffs) + endif + deallocate(item) + nullify(item) + item => next + enddo + + end subroutine shr_exp_list_destroy + + !========================== + ! Private Methods + + ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- + subroutine set_coefvar( term, item ) + character(len=*), intent(in) :: term + type(shr_exp_item_t) , intent(inout) :: item + + integer :: k, n + + item%n_terms = item%n_terms + 1 + n = item%n_terms + + k = scan( term, '*' ) + if (k>0) then + item%vars(n) = trim(adjustl(term(k+1:))) + read( term(:k-1), *) item%coeffs(n) + else + item%vars(n) = trim(adjustl(term)) + item%coeffs(n) = 1.0_r8 + endif + + end subroutine set_coefvar + +end module shr_expr_parser_mod diff --git a/driver-mct/shr/shr_fire_emis_mod.F90 b/driver-mct/shr/shr_fire_emis_mod.F90 new file mode 100644 index 000000000000..d8119652e3f3 --- /dev/null +++ b/driver-mct/shr/shr_fire_emis_mod.F90 @@ -0,0 +1,296 @@ +!================================================================================ +! Coordinates carbon emissions fluxes from CLM fires for use as sources of +! chemical constituents in CAM +! +! This module reads fire_emis_nl namelist which specifies the compound fluxes +! that are to be passed through the model coupler. +!================================================================================ +module shr_fire_emis_mod + + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : CL => SHR_KIND_CL, CX => SHR_KIND_CX, CS => SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : loglev => shr_log_Level + + implicit none + save + private + + public :: shr_fire_emis_readnl ! reads fire_emis_nl namelist + public :: shr_fire_emis_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) than have fire emissions + public :: shr_fire_emis_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have fire emissions + public :: shr_fire_emis_comps_n ! number of unique emissions components + public :: shr_fire_emis_linkedlist ! points to linked list of shr_fire_emis_comp_t objects + public :: shr_fire_emis_elevated ! elevated emissions in ATM + public :: shr_fire_emis_comp_ptr ! user defined type that points to fire emis data obj (shr_fire_emis_comp_t) + public :: shr_fire_emis_comp_t ! emission component data type + public :: shr_fire_emis_mechcomp_t ! data type for chemical compound in CAM mechanism than has fire emissions + + logical :: shr_fire_emis_elevated = .true. + + character(len=CS), public :: shr_fire_emis_fields_token = '' ! emissions fields token + character(len=CL), public :: shr_fire_emis_factors_file = '' ! a table of basic fire emissions compounds + character(len=CS), public :: shr_fire_emis_ztop_token = 'Sl_fztop' ! token for emissions top of vertical distribution + + ! fire emissions component data structure (or user defined type) + type shr_fire_emis_comp_t + character(len=16) :: name ! emissions component name (in fire emissions input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the fire emissions compound (g/mole) + type(shr_fire_emis_comp_t), pointer :: next_emiscomp ! points to next member in the linked list + endtype shr_fire_emis_comp_t + + type shr_fire_emis_comp_ptr + type(shr_fire_emis_comp_t), pointer :: ptr ! points to fire emis data obj (shr_fire_emis_comp_t) + endtype shr_fire_emis_comp_ptr + + ! chemical compound in CAM mechanism that has fire emissions + type shr_fire_emis_mechcomp_t + character(len=16) :: name ! compound name + type(shr_fire_emis_comp_ptr), pointer :: emis_comps(:) ! an array of pointers to fire emis components + integer :: n_emis_comps ! number of fire emis compounds that make up the emissions for this mechanis compound + end type shr_fire_emis_mechcomp_t + + type(shr_fire_emis_mechcomp_t), pointer :: shr_fire_emis_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have fire emissions + type(shr_fire_emis_comp_t), pointer :: shr_fire_emis_linkedlist ! points to linked list top + + integer :: shr_fire_emis_comps_n = 0 ! number of unique fire components + integer :: shr_fire_emis_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have fire emissions + +contains + + !------------------------------------------------------------------------- + ! + ! This reads the fire_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + ! + ! fire_emis_specifier (array of strings) -- Each array element specifies + ! how CAM-Chem constituents are mapped to basic smoke compounds in + ! the fire emissions factors table (fire_emis_factors_file). Each + ! chemistry constituent name (left of '=' sign) is mapped to one or more + ! smoke compound (separated by + sign if more than one), which can be + ! proceeded by a multiplication factor (separated by '*'). + ! Example: + ! fire_emis_specifier = 'bc_a1 = BC','pom_a1 = 1.4*OC','SO2 = SO2' + ! + ! fire_emis_factors_file (string) -- Input file that contains the table + ! of basic compounds that make up the smoke from the CLM fires. This is + ! used in CLM module FireEmisFactorsMod. + ! + ! fire_emis_elevated (locical) -- If true then CAM-Chem treats the fire + ! emission sources as 3-D vertically distributed forcings for the + ! corresponding chemical tracers. + ! + !------------------------------------------------------------------------- + subroutine shr_fire_emis_readnl( NLFileName, ID, emis_fields ) + + use shr_nl_mod, only : shr_nl_find_group_name + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use seq_comm_mct, only : seq_comm_iamroot, seq_comm_setptrs, logunit + use shr_mpi_mod, only : shr_mpi_bcast + + character(len=*), intent(in) :: NLFileName ! name of namelist file + integer , intent(in) :: ID ! seq_comm ID + character(len=*), intent(out) :: emis_fields ! emis flux fields + + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: mpicom ! MPI communicator + + integer, parameter :: maxspc = 100 + + character(len=2*CX) :: fire_emis_specifier(maxspc) = ' ' + character(len=CL) :: fire_emis_factors_file = ' ' + + character(*),parameter :: F00 = "('(shr_fire_emis_readnl) ',2a)" + + logical :: fire_emis_elevated = .true. + + namelist /fire_emis_nl/ fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + + call seq_comm_setptrs(ID,mpicom=mpicom) + if (seq_comm_iamroot(ID)) then + + inquire( file=trim(NLFileName), exist=exists) + + if ( exists ) then + + unitn = shr_file_getUnit() + open( unitn, file=trim(NLFilename), status='old' ) + if ( loglev > 0 ) write(logunit,F00) & + 'Read in fire_emis_readnl namelist from: ', trim(NLFilename) + + call shr_nl_find_group_name(unitn, 'fire_emis_nl', status=ierr) + ! If ierr /= 0, no namelist present. + + if (ierr == 0) then + read(unitn, fire_emis_nl, iostat=ierr) + + if (ierr > 0) then + call shr_sys_abort( 'problem on read of fire_emis_nl namelist in shr_fire_emis_readnl' ) + endif + endif + + close( unitn ) + call shr_file_freeUnit( unitn ) + end if + end if + call shr_mpi_bcast( fire_emis_specifier, mpicom) + call shr_mpi_bcast( fire_emis_factors_file, mpicom) + call shr_mpi_bcast( fire_emis_elevated, mpicom) + + shr_fire_emis_factors_file = fire_emis_factors_file + shr_fire_emis_elevated = fire_emis_elevated + + ! parse the namelist info and initialize the module data + call shr_fire_emis_init( fire_emis_specifier, emis_fields ) + + end subroutine shr_fire_emis_readnl + + !----------------------------------------------------------------------- + ! module data initializer + !------------------------------------------------------------------------ + subroutine shr_fire_emis_init( specifier, emis_fields ) + + use shr_expr_parser_mod, only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + character(len=*), intent(in) :: specifier(:) + character(len=*), intent(out) :: emis_fields + + integer :: n_entries + integer :: i, j, k + + type(shr_exp_item_t), pointer :: items_list, item + character(len=12) :: token ! fire emis field name to add + + nullify(shr_fire_emis_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_fire_emis_mechcomps(n_entries)) + shr_fire_emis_mechcomps(:)%n_emis_comps = 0 + + emis_fields = '' + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_fire_emis_mechcomps_n + if ( trim(shr_fire_emis_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_fire_emis_init : multiple emissions definitions specified for : '//trim(item%name)) + endif + enddo + + shr_fire_emis_mechcomps(i)%name = item%name + shr_fire_emis_mechcomps(i)%n_emis_comps = item%n_terms + allocate(shr_fire_emis_mechcomps(i)%emis_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_fire_emis_mechcomps_n = shr_fire_emis_mechcomps_n+1 + + write(token,333) shr_fire_emis_mechcomps_n + + if ( shr_fire_emis_mechcomps_n == 1 ) then + ! do not prepend ":" to the string for the first token + emis_fields = trim(token) + shr_fire_emis_fields_token = token + else + emis_fields = trim(emis_fields)//':'//trim(token) + endif + + item => item%next_item + i = i+1 + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + ! Need to explicitly add Fl_ based on naming convention +333 format ('Fall_fire',i3.3) + + end subroutine shr_fire_emis_init + + !------------------------------------------------------------------------- + ! private methods... + + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + function add_emis_comp( name, coeff ) result(emis_comp) + + character(len=*), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_fire_emis_comp_t), pointer :: emis_comp + + emis_comp => get_emis_comp_by_name(shr_fire_emis_linkedlist, name) + if(associated(emis_comp)) then + ! already in the list so return... + return + endif + + ! create new emissions component and add it to the list + allocate(emis_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + emis_comp%index = shr_fire_emis_comps_n+1 + + emis_comp%name = trim(name) + emis_comp%coeff = coeff + nullify(emis_comp%next_emiscomp) + + call add_emis_comp_to_list(emis_comp) + + end function add_emis_comp + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + recursive function get_emis_comp_by_name(list_comp, name) result(emis_comp) + + type(shr_fire_emis_comp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_fire_emis_comp_t), pointer :: emis_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + emis_comp => list_comp + else + emis_comp => get_emis_comp_by_name(list_comp%next_emiscomp, name) + end if + else + nullify(emis_comp) + end if + + end function get_emis_comp_by_name + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + subroutine add_emis_comp_to_list( new_emis_comp ) + + type(shr_fire_emis_comp_t), target, intent(in) :: new_emis_comp + + type(shr_fire_emis_comp_t), pointer :: list_comp + + if(associated(shr_fire_emis_linkedlist)) then + list_comp => shr_fire_emis_linkedlist + do while(associated(list_comp%next_emiscomp)) + list_comp => list_comp%next_emiscomp + end do + list_comp%next_emiscomp => new_emis_comp + else + shr_fire_emis_linkedlist => new_emis_comp + end if + + shr_fire_emis_comps_n = shr_fire_emis_comps_n + 1 + + end subroutine add_emis_comp_to_list + +endmodule shr_fire_emis_mod diff --git a/driver-mct/shr/shr_megan_mod.F90 b/driver-mct/shr/shr_megan_mod.F90 new file mode 100644 index 000000000000..6bf90d22e429 --- /dev/null +++ b/driver-mct/shr/shr_megan_mod.F90 @@ -0,0 +1,310 @@ +!================================================================================ +! Handles MEGAN VOC emissions metadata for CLM produced chemical emissions +! MEGAN = Model of Emissions of Gases and Aerosols from Nature +! +! This reads the megan_emis_nl namelist in drv_flds_in and makes the relavent +! information available to CAM, CLM, and driver. The driver sets up CLM to CAM +! communication for the VOC flux fields. CLM needs to know what specific VOC +! fluxes need to be passed to the coupler and how to assimble the fluxes. +! CAM needs to know what specific VOC fluxes to expect from CLM. +! +! Francis Vitt -- 26 Oct 2011 +!================================================================================ +module shr_megan_mod + + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : CL => SHR_KIND_CL, CX => SHR_KIND_CX, CS => SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : loglev => shr_log_Level + use shr_log_mod, only : logunit => shr_log_Unit + + implicit none + save + private + + public :: shr_megan_readnl ! reads megan_emis_nl namelist + public :: shr_megan_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) that have MEGAN emissions + public :: shr_megan_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + public :: shr_megan_megcomps_n ! number of unique MEGAN compounds + public :: shr_megan_megcomp_t ! MEGAN compound data type + public :: shr_megan_mechcomp_t ! data type for chemical compound in CAM mechanism that has MEGAN emissions + public :: shr_megan_linkedlist ! points to linked list of shr_megan_comp_t objects + public :: shr_megan_mapped_emisfctrs ! switch to use mapped emission factors + public :: shr_megan_comp_ptr + + character(len=CS), public :: shr_megan_fields_token = '' ! First drydep fields token + character(len=CL), public :: shr_megan_factors_file = '' + + ! MEGAN compound data structure (or user defined type) + type shr_megan_megcomp_t + character(len=16) :: name ! MEGAN compound name (in MEGAN input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + integer :: class_number ! MEGAN class number + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the MEGAN compound (g/mole) + type(shr_megan_megcomp_t), pointer :: next_megcomp ! points to next member in the linked list + endtype shr_megan_megcomp_t + + type shr_megan_comp_ptr + type(shr_megan_megcomp_t), pointer :: ptr + endtype shr_megan_comp_ptr + + ! chemical compound in CAM mechanism that has MEGAN emissions + type shr_megan_mechcomp_t + character(len=16) :: name ! compound name + type(shr_megan_comp_ptr), pointer :: megan_comps(:) ! an array of pointers to megan emis compounds + integer :: n_megan_comps ! number of megan emis compounds that make up the emissions for this mechanis compound + end type shr_megan_mechcomp_t + + type(shr_megan_mechcomp_t), pointer :: shr_megan_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have MEGAN emissions + type(shr_megan_megcomp_t), pointer :: shr_megan_linkedlist ! points to linked list top + + integer :: shr_megan_megcomps_n = 0 ! number of unique megan compounds + integer :: shr_megan_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + + ! switch to use mapped emission factors + logical :: shr_megan_mapped_emisfctrs = .false. + +contains + + !------------------------------------------------------------------------- + ! + ! This reads the megan_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! megan_specifier, megan_mapped_emisfctrs, megan_factors_file + ! + ! megan_specifier is a series of strings where each string contains one + ! CAM chemistry constituent name (left of = sign) and one or more MEGAN + ! compound (separated by + sign if more than one). Each MEGAN compound + ! can be proceeded by a multiplication factor (separated by *). The + ! specification of the MEGAN compounds to the right of the = signs tells + ! the MEGAN VOC model within CLM how to construct the VOC fluxes using + ! the factors in megan_factors_file and land surface state. + ! + ! megan_factors_file read by CLM contains valid MEGAN compound names, + ! MEGAN class groupings and scalar emission factors + ! + ! megan_mapped_emisfctrs switch is used to tell the MEGAN model to use + ! mapped emission factors read in from the CLM surface data input file + ! rather than the scalar factors from megan_factors_file + ! + ! Example: + ! &megan_emis_nl + ! megan_specifier = 'ISOP = isoprene', + ! 'C10H16 = myrcene + sabinene + limonene + carene_3 + ocimene_t_b + pinene_b + ...', + ! 'CH3OH = methanol', + ! 'C2H5OH = ethanol', + ! 'CH2O = formaldehyde', + ! 'CH3CHO = acetaldehyde', + ! ... + ! megan_factors_file = '$datapath/megan_emis_factors.nc' + ! / + !------------------------------------------------------------------------- + subroutine shr_megan_readnl( NLFileName, ID, megan_fields ) + + use shr_nl_mod, only : shr_nl_find_group_name + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use seq_comm_mct, only : seq_comm_iamroot, seq_comm_setptrs + use shr_mpi_mod, only : shr_mpi_bcast + + character(len=*), intent(in) :: NLFileName + integer , intent(in) :: ID ! seq_comm ID + character(len=*), intent(out) :: megan_fields + + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: mpicom ! MPI communicator + + integer, parameter :: maxspc = 100 + + character(len=2*CX) :: megan_specifier(maxspc) = ' ' + logical :: megan_mapped_emisfctrs = .false. + character(len=CL) :: megan_factors_file = ' ' + + character(*),parameter :: F00 = "('(shr_megan_readnl) ',2a)" + + namelist /megan_emis_nl/ megan_specifier, megan_factors_file, megan_mapped_emisfctrs + + call seq_comm_setptrs(ID,mpicom=mpicom) + if (seq_comm_iamroot(ID)) then + inquire( file=trim(NLFileName), exist=exists) + + if ( exists ) then + + unitn = shr_file_getUnit() + open( unitn, file=trim(NLFilename), status='old' ) + if ( loglev > 0 ) write(logunit,F00) & + 'Read in megan_emis_readnl namelist from: ', trim(NLFilename) + + call shr_nl_find_group_name(unitn, 'megan_emis_nl', status=ierr) + ! If ierr /= 0, no namelist present. + + if (ierr == 0) then + read(unitn, megan_emis_nl, iostat=ierr) + + if (ierr > 0) then + call shr_sys_abort( 'problem on read of megan_emis_nl namelist in shr_megan_readnl' ) + endif + endif + + close( unitn ) + call shr_file_freeUnit( unitn ) + + end if + end if + call shr_mpi_bcast( megan_specifier, mpicom ) + call shr_mpi_bcast( megan_factors_file, mpicom ) + call shr_mpi_bcast( megan_mapped_emisfctrs, mpicom ) + + shr_megan_factors_file = megan_factors_file + shr_megan_mapped_emisfctrs = megan_mapped_emisfctrs + + ! parse the namelist info and initialize the module data + call shr_megan_init( megan_specifier, megan_fields ) + + end subroutine shr_megan_readnl + + !------------------------------------------------------------------------- + ! module data initializer + !------------------------------------------------------------------------- + subroutine shr_megan_init( specifier, megan_fields ) + + use shr_expr_parser_mod, only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + character(len=*), intent(in) :: specifier(:) + character(len=*), intent(out) :: megan_fields + + integer :: n_entries + integer :: i, j, k + + type(shr_exp_item_t), pointer :: items_list, item + character(len=12) :: token ! megan field name to add + + nullify(shr_megan_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_megan_mechcomps(n_entries)) + shr_megan_mechcomps(:)%n_megan_comps = 0 + + megan_fields = '' + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_megan_mechcomps_n + if ( trim(shr_megan_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_megan_init : duplicate compound names : '//trim(item%name)) + endif + enddo + + shr_megan_mechcomps(i)%name = item%name + shr_megan_mechcomps(i)%n_megan_comps = item%n_terms + allocate(shr_megan_mechcomps(i)%megan_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_megan_mechcomps(i)%megan_comps(j)%ptr => add_megan_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_megan_mechcomps_n = shr_megan_mechcomps_n+1 + + write(token,333) shr_megan_mechcomps_n + + if ( shr_megan_mechcomps_n == 1 ) then + ! do not prepend ":" to the string for the first token + megan_fields = trim(token) + shr_megan_fields_token = token + else + megan_fields = trim(megan_fields)//':'//trim(token) + endif + + item => item%next_item + i = i+1 + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + ! Need to explicitly add Fl_ based on naming convention +333 format ('Fall_voc',i3.3) + + end subroutine shr_megan_init + + !------------------------------------------------------------------------- + ! private methods... + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + function add_megan_comp( name, coeff ) result(megan_comp) + + character(len=16), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_megan_megcomp_t), pointer :: megan_comp + + megan_comp => get_megan_comp_by_name(shr_megan_linkedlist, name) + if(associated(megan_comp)) then + ! already in the list so return... + return + endif + + ! create new megan compound and add it to the list + allocate(megan_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + megan_comp%index = shr_megan_megcomps_n+1 + + megan_comp%name = trim(name) + megan_comp%coeff = coeff + nullify(megan_comp%next_megcomp) + + call add_megan_comp_to_list(megan_comp) + + end function add_megan_comp + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + recursive function get_megan_comp_by_name(list_comp, name) result(megan_comp) + + type(shr_megan_megcomp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_megan_megcomp_t), pointer :: megan_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + megan_comp => list_comp + else + megan_comp => get_megan_comp_by_name(list_comp%next_megcomp, name) + end if + else + nullify(megan_comp) + end if + + end function get_megan_comp_by_name + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + subroutine add_megan_comp_to_list( new_megan_comp ) + + type(shr_megan_megcomp_t), target, intent(in) :: new_megan_comp + + type(shr_megan_megcomp_t), pointer :: list_comp + + if(associated(shr_megan_linkedlist)) then + list_comp => shr_megan_linkedlist + do while(associated(list_comp%next_megcomp)) + list_comp => list_comp%next_megcomp + end do + list_comp%next_megcomp => new_megan_comp + else + shr_megan_linkedlist => new_megan_comp + end if + + shr_megan_megcomps_n = shr_megan_megcomps_n + 1 + + end subroutine add_megan_comp_to_list + +endmodule shr_megan_mod diff --git a/driver-mct/shr/shr_ndep_mod.F90 b/driver-mct/shr/shr_ndep_mod.F90 new file mode 100644 index 000000000000..f1d602a34fce --- /dev/null +++ b/driver-mct/shr/shr_ndep_mod.F90 @@ -0,0 +1,117 @@ +module shr_ndep_mod + + !======================================================================== + ! Module for handling nitrogen depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + !======================================================================== + + !USES: + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_kind_mod, only : r8 => shr_kind_r8, CS => SHR_KIND_CS, CX => SHR_KIND_CX + + implicit none + save + + private + + ! !PUBLIC MEMBER FUNCTIONS + public :: shr_ndep_readnl ! Read namelist + !==================================================================================== + +CONTAINS + + !==================================================================================== + subroutine shr_ndep_readnl(NLFilename, ID, ndep_fields, add_ndep_fields) + + !======================================================================== + ! reads ndep_inparm namelist and sets up driver list of fields for + ! atmosphere -> land and atmosphere -> ocn communications. + !======================================================================== + + use shr_file_mod , only : shr_file_getUnit, shr_file_freeUnit + use shr_log_mod , only : s_logunit => shr_log_Unit + use seq_comm_mct , only : seq_comm_iamroot, seq_comm_setptrs + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + implicit none + + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer , intent(in) :: ID ! seq_comm ID + character(len=*), intent(out) :: ndep_fields + logical , intent(out) :: add_ndep_fields + + !----- local ----- + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + character(len=8) :: token ! dry dep field name to add + integer :: mpicom ! MPI communicator + + integer, parameter :: maxspc = 100 ! Maximum number of species + character(len=32) :: ndep_list(maxspc) = '' ! List of ndep species + + !----- formats ----- + character(*),parameter :: subName = '(shr_ndep_read) ' + character(*),parameter :: F00 = "('(shr_ndep_read) ',8a)" + character(*),parameter :: FI1 = "('(shr_ndep_init) ',a,I2)" + + namelist /ndep_inparm/ ndep_list + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the ndep field list to pass + ! First check if file exists and if not, n_ndep will be zero + !----------------------------------------------------------------------------- + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + call seq_comm_setptrs(ID,mpicom=mpicom) + if (seq_comm_iamroot(ID)) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + unitn = shr_file_getUnit() + open( unitn, file=trim(NLFilename), status='old' ) + if ( s_loglev > 0 ) then + write(s_logunit,F00) 'Read in ndep_inparm namelist from: ', trim(NLFilename) + end if + call shr_nl_find_group_name(unitn, 'ndep_inparm', ierr) + if (ierr == 0) then + ierr = 1 + do while ( ierr /= 0 ) + read(unitn, ndep_inparm, iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subName//'ERROR: encountered end-of-file on namelist read' ) + endif + end do + else + write(s_logunit,*) 'shr_ndep_readnl: no ndep_inparm namelist found in ',NLFilename + endif + close( unitn ) + call shr_file_freeUnit( unitn ) + end if + end if + call shr_mpi_bcast( ndep_list, mpicom ) + + ndep_fields = ' ' + if (len_trim(ndep_list(1)) == 0) then + add_ndep_fields = .false. + else + ! Loop over species to fill list of fields to communicate for ndep + add_ndep_fields = .true. + do i=1,maxspc + if ( len_trim(ndep_list(i))==0 ) exit + if ( i == 1 ) then + ndep_fields = 'Faxa_' // trim(ndep_list(i)) + else + ndep_fields = trim(ndep_fields)//':'//'Faxa_' // trim(ndep_list(i)) + endif + enddo + end if + + end subroutine shr_ndep_readnl + +end module shr_ndep_mod diff --git a/driver-mct/unit_test/CMakeLists.txt b/driver-mct/unit_test/CMakeLists.txt new file mode 100644 index 000000000000..8210b71da8af --- /dev/null +++ b/driver-mct/unit_test/CMakeLists.txt @@ -0,0 +1,65 @@ +set(DRV_ROOT "${CIME_ROOT}/src/drivers/mct") + +add_definitions( + -DNUM_COMP_INST_ATM=1 + -DNUM_COMP_INST_LND=1 + -DNUM_COMP_INST_OCN=1 + -DNUM_COMP_INST_ICE=1 + -DNUM_COMP_INST_GLC=1 + -DNUM_COMP_INST_WAV=1 + -DNUM_COMP_INST_ROF=1 + -DNUM_COMP_INST_ESP=1 + ) + +# The following definitions are needed when building with the mpi-serial library +if (USE_MPI_SERIAL) + add_definitions(-DNO_MPI2 -DNO_MPIMOD) +endif() + +# Add source directories from stubs. This should be done first, so that in the +# case of name collisions, the drv versions take precedence (when there are two +# files with the same name, the one added later wins). +add_subdirectory(${CIME_ROOT}/src/share/unit_test_stubs/pio pio) + +# Add drv source directories +add_subdirectory(${DRV_ROOT}/shr drv_shr) +add_subdirectory(${DRV_ROOT}/main drv_main) + +# Add general unit test directories (stubbed out files, etc.) +add_subdirectory(utils drv_unit_test_utils) +add_subdirectory(stubs drv_unit_test_stubs) + +# Build libraries containing stuff needed for the unit tests. +# Eventually, these add_library calls should probably be distributed into the +# correct location, rather than being in this top-level CMakeLists.txt file. +# Note that we are including the stub pio in the csm_share library for simplicity. +add_library(csm_share ${share_sources} ${share_mct_sources} ${share_pio_sources} + ${pio_sources}) +declare_generated_dependencies(csm_share "${share_genf90_sources}") +declare_generated_dependencies(csm_share "${pio_genf90_sources}") +add_dependencies(csm_share mct_project) + +add_library(esmf_wrf_timemgr ${esmf_wrf_timemgr_sources}) +add_dependencies(esmf_wrf_timemgr csm_share) + +add_library(drv ${drv_sources}) +add_dependencies(drv csm_share esmf_wrf_timemgr) + +include_directories(${CMAKE_CURRENT_BINARY_DIR}) + +# Set the list of libraries needed for these unit tests. Note that not all unit +# tests need all of these libraries, but it's easiest just to set the same list +# for everyone. +set(DRV_UNIT_TEST_LIBS drv;csm_share;esmf_wrf_timemgr;mct;mpeu) +if (USE_MPI_SERIAL) + list(APPEND DRV_UNIT_TEST_LIBS mpi-serial) +endif() +list(APPEND DRV_UNIT_TEST_LIBS ${NETCDF_LIBRARIES}) + +# Add the test directories +add_subdirectory(avect_wrapper_test) +add_subdirectory(seq_map_test) +add_subdirectory(glc_elevclass_test) +add_subdirectory(map_glc2lnd_test) +add_subdirectory(map_lnd2rof_irrig_test) +add_subdirectory(check_fields_test) diff --git a/driver-mct/unit_test/avect_wrapper_test/CMakeLists.txt b/driver-mct/unit_test/avect_wrapper_test/CMakeLists.txt new file mode 100644 index 000000000000..f22aacc633d6 --- /dev/null +++ b/driver-mct/unit_test/avect_wrapper_test/CMakeLists.txt @@ -0,0 +1,4 @@ +create_pFUnit_test(avect_wrapper avect_wrapper_exe + "test_avect_wrapper.pf" "") + +target_link_libraries(avect_wrapper_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/avect_wrapper_test/test_avect_wrapper.pf b/driver-mct/unit_test/avect_wrapper_test/test_avect_wrapper.pf new file mode 100644 index 000000000000..4558c20eccbe --- /dev/null +++ b/driver-mct/unit_test/avect_wrapper_test/test_avect_wrapper.pf @@ -0,0 +1,87 @@ +module test_avect_wrapper + + ! Tests of avect_wrapper_mod, a module with some unit test utilities + + use pfunit_mod + use avect_wrapper_mod + use mct_mod + use mct_wrapper_mod, only : mct_init, mct_clean + use shr_kind_mod, only : r8 => shr_kind_r8 + + implicit none + + @TestCase + type, extends(TestCase) :: TestCreateAvect + type(mct_aVect) :: av + contains + procedure :: setUp + procedure :: tearDown + end type TestCreateAvect + +contains + + subroutine setUp(this) + class(TestCreateAvect), intent(inout) :: this + + call mct_init() + end subroutine setUp + + subroutine tearDown(this) + class(TestCreateAvect), intent(inout) :: this + + call mct_aVect_clean(this%av) + call mct_clean() + end subroutine tearDown + + @Test + subroutine createAVectWithoutData_1Field_checkField(this) + class(TestCreateAvect), intent(inout) :: this + character(len=*), parameter :: attr_tag = 'foo' + integer, parameter :: lsize = 5 ! not important for this test + character(len=64) :: actual_rlist + + call create_aVect_without_data(this%av, [attr_tag], lsize) + + actual_rlist = mct_aVect_exportRList2c(this%av) + @assertEqual('foo', trim(actual_rlist)) + end subroutine createAVectWithoutData_1Field_checkField + + @Test + subroutine createAVectWithoutData_3Field_checkFields(this) + class(TestCreateAvect), intent(inout) :: this + character(len=*), parameter :: attr_tag1 = 'foo1' + character(len=*), parameter :: attr_tag2 = 'foo2' + character(len=*), parameter :: attr_tag3 = 'bar ' + character(len=*), parameter :: expected_rlist = 'foo1:foo2:bar' + integer, parameter :: lsize = 5 ! not important for this test + character(len=64) :: actual_rlist + + call create_aVect_without_data(this%av, [attr_tag1, attr_tag2, attr_tag3], lsize) + + actual_rlist = mct_aVect_exportRList2c(this%av) + @assertEqual(expected_rlist, actual_rlist) + end subroutine createAVectWithoutData_3Field_checkFields + + @Test + subroutine createAvectWithData_2Fields_checkData(this) + class(TestCreateAvect), intent(inout) :: this + integer, parameter :: lsize = 3 + ! note that the two attributes have different trimmed length + character(len=4), parameter :: attr_tag1 = 'foo' + character(len=4), parameter :: attr_tag2 = 'bar2' + real(r8), parameter :: data1(lsize) = [1._r8, 2._r8, 3._r8] + real(r8), parameter :: data2(lsize) = [11._r8, 12._r8, 13._r8] + real(r8), allocatable :: actual_data1(:), actual_data2(:) + + call create_aVect_with_data_rows_are_points(this%av, & + attr_tags = [attr_tag1, attr_tag2], & + data = reshape([data1, data2], [lsize, 2])) + + actual_data1 = aVect_exportRattr(this%av, attr_tag1) + @assertEqual(data1, actual_data1) + actual_data2 = aVect_exportRattr(this%av, attr_tag2) + @assertEqual(data2, actual_data2) + + end subroutine createAvectWithData_2Fields_checkData + +end module test_avect_wrapper diff --git a/driver-mct/unit_test/check_fields_test/CMakeLists.txt b/driver-mct/unit_test/check_fields_test/CMakeLists.txt new file mode 100644 index 000000000000..1c6aeefb79d4 --- /dev/null +++ b/driver-mct/unit_test/check_fields_test/CMakeLists.txt @@ -0,0 +1,4 @@ +create_pFUnit_test(check_fields check_fields_exe + "test_check_fields.pf" "") + +target_link_libraries(check_fields_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/check_fields_test/test_check_fields.pf b/driver-mct/unit_test/check_fields_test/test_check_fields.pf new file mode 100644 index 000000000000..772d22ec0d58 --- /dev/null +++ b/driver-mct/unit_test/check_fields_test/test_check_fields.pf @@ -0,0 +1,99 @@ +module test_check_fields + + ! Tests of check_fields in the component_type_mod, check_fields looks for NaN values + ! in fields passed from components to the coupler + + use pfunit_mod + use component_type_mod + use mct_mod + use mct_wrapper_mod, only : mct_init, mct_clean + use avect_wrapper_mod + use create_mapper_mod + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_infnan_mod, only : shr_infnan_nan, assignment(=) + implicit none + + @TestCase + type, extends(TestCase) :: TestCheckFields + type(component_type) :: comp + contains + procedure :: setUp + procedure :: tearDown + end type TestCheckFields + +contains + + subroutine setUp(this) + class(TestCheckFields), intent(inout) :: this + + call mct_init() + end subroutine setUp + + subroutine tearDown(this) + class(TestCheckFields), intent(inout) :: this + call mct_aVect_clean(this%comp%c2x_cc) + call mct_clean() + end subroutine tearDown + + @Test + subroutine createAVectWithoutData_1Field_checkField(this) + class(TestCheckFields), intent(inout) :: this + character(len=*), parameter :: attr_tag = 'foo' + integer, parameter :: lsize = 5 ! + character(len=64) :: actual_rlist + real(r8) :: nan + + nan = shr_infnan_nan + if(.not. associated(this%comp%c2x_cc)) allocate(this%comp%c2x_cc) + call create_aVect_without_data(this%comp%c2x_cc, [attr_tag], lsize) + + actual_rlist = mct_aVect_exportRList2c(this%comp%c2x_cc) + @assertEqual('foo', trim(actual_rlist)) + + this%comp%c2x_cc%rattr(1,3) = nan + + this%comp%name = 'pfunittest' + + if(.not. associated(this%comp%gsmap_cc)) allocate(this%comp%gsmap_cc) + + call create_gsmap(this%comp%gsmap_cc, lsize) + + call check_fields(this%comp, 1) + @assertExceptionRaised('ABORTED: component_mod:check_fields NaN found in pfunittest instance: 1 field foo 1d global index: 3') + + end subroutine createAVectWithoutData_1Field_checkField + + @Test + subroutine createAVectWithoutData_3Field_checkFields(this) + class(TestCheckFields), intent(inout) :: this + character(len=*), parameter :: attr_tag1 = 'foo1' + character(len=*), parameter :: attr_tag2 = 'foo2' + character(len=*), parameter :: attr_tag3 = 'bar ' + character(len=*), parameter :: expected_rlist = 'foo1:foo2:bar' + integer, parameter :: lsize = 5 ! not important for this test + character(len=64) :: actual_rlist + real(r8) :: nan + + nan = shr_infnan_nan + + this%comp%name = 'pfunittest' + + if(.not. associated(this%comp%c2x_cc)) allocate(this%comp%c2x_cc) + + call create_aVect_without_data(this%comp%c2x_cc, [attr_tag1, attr_tag2, attr_tag3], lsize) + + actual_rlist = mct_aVect_exportRList2c(this%comp%c2x_cc) + @assertEqual(expected_rlist, actual_rlist) + + if(.not. associated(this%comp%gsmap_cc)) allocate(this%comp%gsmap_cc) + + this%comp%c2x_cc%rattr(2,3) = nan + + call create_gsmap(this%comp%gsmap_cc, lsize) + + call check_fields(this%comp, 1) + + @assertExceptionRaised('ABORTED: component_mod:check_fields NaN found in pfunittest instance: 1 field foo2 1d global index: 3') + end subroutine createAVectWithoutData_3Field_checkFields + +end module test_check_fields diff --git a/driver-mct/unit_test/glc_elevclass_test/CMakeLists.txt b/driver-mct/unit_test/glc_elevclass_test/CMakeLists.txt new file mode 100644 index 000000000000..25831e414e08 --- /dev/null +++ b/driver-mct/unit_test/glc_elevclass_test/CMakeLists.txt @@ -0,0 +1,4 @@ +create_pFUnit_test(glc_elevclass glc_elevclass_exe + "test_glc_elevclass.pf" "") + +target_link_libraries(glc_elevclass_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/glc_elevclass_test/test_glc_elevclass.pf b/driver-mct/unit_test/glc_elevclass_test/test_glc_elevclass.pf new file mode 100644 index 000000000000..f0f8ebed22a1 --- /dev/null +++ b/driver-mct/unit_test/glc_elevclass_test/test_glc_elevclass.pf @@ -0,0 +1,286 @@ +module test_glc_elevclass + + ! Tests of glc_elevclass_mod + + use pfunit_mod + use glc_elevclass_mod + use shr_kind_mod, only : r8 => shr_kind_r8 + + implicit none + + @TestCase + type, extends(TestCase) :: TestGLCElevclass + contains + procedure :: setUp + procedure :: tearDown + end type TestGLCElevclass + +contains + + subroutine setUp(this) + class(TestGLCElevclass), intent(inout) :: this + end subroutine setUp + + subroutine tearDown(this) + class(TestGLCElevclass), intent(inout) :: this + + call glc_elevclass_clean() + end subroutine tearDown + + ! ------------------------------------------------------------------------ + ! Tests of glc_elevclass_init + ! ------------------------------------------------------------------------ + + @Test + subroutine test_init_with_0ECs(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: num_elevation_classes + + call glc_elevclass_init(0) + + num_elevation_classes = glc_get_num_elevation_classes() + @assertEqual(0, num_elevation_classes) + end subroutine test_init_with_0ECs + + @Test + subroutine test_init_with_1EC(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: num_elevation_classes + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(1) + + num_elevation_classes = glc_get_num_elevation_classes() + @assertEqual(1, num_elevation_classes) + call glc_get_elevation_class(9999._r8, elevation_class, err_code) + @assertEqual(1, elevation_class) + end subroutine test_init_with_1EC + + @Test + subroutine test_init_with_10ECs(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: num_elevation_classes + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(10) + + num_elevation_classes = glc_get_num_elevation_classes() + @assertEqual(10, num_elevation_classes) + call glc_get_elevation_class(9999._r8, elevation_class, err_code) + @assertEqual(10, elevation_class) + end subroutine test_init_with_10ECs + + ! ------------------------------------------------------------------------ + ! Tests of glc_get_elevation_class + ! ------------------------------------------------------------------------ + + @Test + subroutine test_glc_get_elevation_class_lowest(this) + ! Test an elevation in the lowest elevation class + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(1._r8, elevation_class, err_code) + @assertEqual(1, elevation_class) + end subroutine test_glc_get_elevation_class_lowest + + @Test + subroutine test_glc_get_elevation_class_mid(this) + ! Test an elevation in a middle elevation class + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(150._r8, elevation_class, err_code) + @assertEqual(2, elevation_class) + end subroutine test_glc_get_elevation_class_mid + + @Test + subroutine test_glc_get_elevation_class_highest(this) + ! Test an elevation in the highest elevation class + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(250._r8, elevation_class, err_code) + @assertEqual(3, elevation_class) + end subroutine test_glc_get_elevation_class_highest + + + ! Test glc_get_elevation_class error return values (one test for each possibility) + + @Test + subroutine test_glc_get_elevation_class_err_none(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(1._r8, elevation_class, err_code) + @assertEqual(GLC_ELEVCLASS_ERR_NONE, err_code) + end subroutine test_glc_get_elevation_class_err_none + + @Test + subroutine test_glc_get_elevation_class_err_low(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(-1._r8, elevation_class, err_code) + @assertEqual(GLC_ELEVCLASS_ERR_TOO_LOW, err_code) + @assertEqual(1, elevation_class) + end subroutine test_glc_get_elevation_class_err_low + + @Test + subroutine test_glc_get_elevation_class_err_high(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + + call glc_get_elevation_class(301._r8, elevation_class, err_code) + @assertEqual(GLC_ELEVCLASS_ERR_TOO_HIGH, err_code) + @assertEqual(3, elevation_class) + end subroutine test_glc_get_elevation_class_err_high + + @Test + subroutine test_glc_get_elevation_class_err_undefined(this) + class(TestGLCElevclass), intent(inout) :: this + integer :: elevation_class + integer :: err_code + + call glc_elevclass_init(0) + + call glc_get_elevation_class(1._r8, elevation_class, err_code) + @assertEqual(GLC_ELEVCLASS_ERR_UNDEFINED, err_code) + @assertEqual(0, elevation_class) + end subroutine test_glc_get_elevation_class_err_undefined + + ! ------------------------------------------------------------------------ + ! Tests of glc_mean_elevation_virtual + ! ------------------------------------------------------------------------ + + @Test + subroutine test_glc_mean_elevation_virtual_EC0(this) + class(TestGLCElevclass), intent(inout) :: this + real(r8) :: mean_elevation + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + mean_elevation = glc_mean_elevation_virtual(0) + @assertEqual(0._r8, mean_elevation) + end subroutine test_glc_mean_elevation_virtual_EC0 + + @Test + subroutine test_glc_mean_elevation_virtual_EC_mid(this) + ! Tests an elevation class in the middle of the range (normal case) + class(TestGLCElevclass), intent(inout) :: this + real(r8) :: mean_elevation + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 300._r8]) + mean_elevation = glc_mean_elevation_virtual(2) + @assertEqual(150._r8, mean_elevation) + end subroutine test_glc_mean_elevation_virtual_EC_mid + + @Test + subroutine test_glc_mean_elevation_virtual_EC_top(this) + ! Tests an elevation class at the top of the range + class(TestGLCElevclass), intent(inout) :: this + real(r8) :: mean_elevation + + call glc_elevclass_init(3, [0._r8, 100._r8, 200._r8, 1000._r8]) + mean_elevation = glc_mean_elevation_virtual(3) + @assertEqual(300._r8, mean_elevation) + end subroutine test_glc_mean_elevation_virtual_EC_top + + @Test + subroutine test_glc_mean_elevation_virtual_EC_oneEC(this) + ! Tests a single elevation class + class(TestGLCElevclass), intent(inout) :: this + real(r8) :: mean_elevation + + call glc_elevclass_init(1) + mean_elevation = glc_mean_elevation_virtual(1) + @assertEqual(1000._r8, mean_elevation) + end subroutine test_glc_mean_elevation_virtual_EC_oneEC + + ! ------------------------------------------------------------------------ + ! Tests of glc_elevclass_as_string + ! ------------------------------------------------------------------------ + + @Test + subroutine test_glc_elevclass_as_string_0(this) + class(TestGLCElevclass), intent(inout) :: this + character(len=GLC_ELEVCLASS_STRLEN) :: str + + str = glc_elevclass_as_string(0) + @assertEqual('00', trim(str)) + end subroutine test_glc_elevclass_as_string_0 + + @Test + subroutine test_glc_elevclass_as_string_1digit(this) + class(TestGLCElevclass), intent(inout) :: this + character(len=GLC_ELEVCLASS_STRLEN) :: str + + str = glc_elevclass_as_string(2) + @assertEqual('02', trim(str)) + end subroutine test_glc_elevclass_as_string_1digit + + @Test + subroutine test_glc_elevclass_as_string_2digits(this) + class(TestGLCElevclass), intent(inout) :: this + character(len=GLC_ELEVCLASS_STRLEN) :: str + + str = glc_elevclass_as_string(12) + @assertEqual('12', trim(str)) + end subroutine test_glc_elevclass_as_string_2digits + + ! ------------------------------------------------------------------------ + ! Tests of glc_all_elevclass_strings + ! ------------------------------------------------------------------------ + + @Test + subroutine test_glc_all_elevclass_strings(this) + class(TestGLCElevclass), intent(inout) :: this + character(len=GLC_ELEVCLASS_STRLEN), allocatable :: elevclass_strings(:) + + call glc_elevclass_init(3) + elevclass_strings = glc_all_elevclass_strings() + + @assertEqual(3, size(elevclass_strings)) + ! There doesn't seem to be an assertEqual method for an array of strings + @assertEqual('01', elevclass_strings(1)) + @assertEqual('02', elevclass_strings(2)) + @assertEqual('03', elevclass_strings(3)) + end subroutine test_glc_all_elevclass_strings + + @Test + subroutine test_glc_all_elevclass_strings_include_zero(this) + class(TestGLCElevclass), intent(inout) :: this + character(len=GLC_ELEVCLASS_STRLEN), allocatable :: elevclass_strings(:) + + call glc_elevclass_init(3) + elevclass_strings = glc_all_elevclass_strings(include_zero=.true.) + + @assertEqual(4, size(elevclass_strings)) + ! There doesn't seem to be an assertEqual method for an array of strings + @assertEqual('00', elevclass_strings(1)) + @assertEqual('01', elevclass_strings(2)) + @assertEqual('02', elevclass_strings(3)) + @assertEqual('03', elevclass_strings(4)) + end subroutine test_glc_all_elevclass_strings_include_zero + + +end module test_glc_elevclass diff --git a/driver-mct/unit_test/map_glc2lnd_test/CMakeLists.txt b/driver-mct/unit_test/map_glc2lnd_test/CMakeLists.txt new file mode 100644 index 000000000000..a35e066321da --- /dev/null +++ b/driver-mct/unit_test/map_glc2lnd_test/CMakeLists.txt @@ -0,0 +1,8 @@ +set (pfunit_sources + test_map_glc2lnd.pf + ) + +create_pFUnit_test(map_glc2lnd map_glc2lnd_exe + "${pfunit_sources}" "") + +target_link_libraries(map_glc2lnd_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/map_glc2lnd_test/test_map_glc2lnd.pf b/driver-mct/unit_test/map_glc2lnd_test/test_map_glc2lnd.pf new file mode 100644 index 000000000000..f48cccac7e08 --- /dev/null +++ b/driver-mct/unit_test/map_glc2lnd_test/test_map_glc2lnd.pf @@ -0,0 +1,985 @@ +module test_map_glc2lnd + + ! Tests of map_glc2lnd_mod + + use pfunit_mod + use map_glc2lnd_mod + use glc_elevclass_mod, only : glc_elevclass_init, glc_elevclass_clean, & + glc_mean_elevation_virtual, glc_elevclass_as_string + use mct_mod, only : mct_aVect, mct_aVect_clean, mct_aVect_lsize + use seq_map_type_mod, only : seq_map + use mct_wrapper_mod, only : mct_init, mct_clean + use avect_wrapper_mod + use simple_map_mod + use create_mapper_mod + use shr_kind_mod, only : r8 => shr_kind_r8 + + implicit none + + real(r8), parameter :: tol = 1.e-11_r8 + + integer, parameter :: n_elev_classes = 3 + + ! Assume 3 elevation classes, with boundaries of: + ! (1) 0 - 100 m + ! (2) 100 - 200 m + ! (3) 200 - 1000 m + real(r8), parameter :: elev_class_boundaries(0:n_elev_classes) = & + [0._r8, 100._r8, 200._r8, 1000._r8] + + ! This type holds data for a single field in a single land grid cell + type :: lnd_field_type + ! Index 0 is bare land + real(r8) :: data(0:n_elev_classes) + end type lnd_field_type + + @TestCase + type, extends(TestCase) :: TestMapGlc2lnd + type(seq_map) :: mapper + type(mct_aVect) :: data_g ! data on the GLC (source) grid + type(mct_aVect) :: data_l ! data on the LND (destination) GRID + contains + procedure :: setUp + procedure :: tearDown + procedure :: setup_inputs + procedure :: setup_inputs_lnd_fully_outside_static_glc_domain + procedure :: setup_inputs_lnd_partially_outside_static_glc_domain + procedure :: setup_inputs_lnd_fully_outside_dynamic_glc_domain + procedure :: setup_inputs_lnd_partially_outside_dynamic_glc_domain + procedure :: run_map_glc2lnd_ec + procedure :: verify_data_l_field + end type TestMapGlc2lnd + +contains + + ! ======================================================================== + ! Utility routines + ! ======================================================================== + + subroutine setUp(this) + class(TestMapGlc2lnd), intent(inout) :: this + + call mct_init() + + end subroutine setUp + + subroutine tearDown(this) + class(TestMapGlc2lnd), intent(inout) :: this + + call clean_mapper(this%mapper) + call mct_aVect_clean(this%data_l) + call mct_aVect_clean(this%data_g) + call glc_elevclass_clean() + call mct_clean() + end subroutine tearDown + + subroutine setup_inputs(this, frac_glc, topo_glc, my_map, data_glc, icemask_glc) + ! This utility function sets up inputs that are needed for the map_glc2lnd_ec call + class(TestMapGlc2lnd), intent(inout) :: this + real(r8), intent(in) :: frac_glc(:) ! ice fraction in each glc cell + real(r8), intent(in) :: topo_glc(:) ! ice topographic height in each glc cell + type(simple_map_type), intent(in) :: my_map ! mapping information from glc to land + + ! Optional extra data field on the glc grid, put in field named 'data' (if not + ! present, the 'data' field is filled with all 0's). + real(r8), intent(in), optional :: data_glc(:) + + ! Optional ice mask on the glc grid. If not present, it is filled with all 1's + real(r8), intent(in), optional :: icemask_glc(:) + + real(r8), allocatable :: l_data_glc(:) ! local version of data_glc + real(r8), allocatable :: l_icemask_glc(:) ! local version of icemask_glc + integer :: npts_glc + integer :: npts_lnd + + ! ------------------------------------------------------------------------ + ! Do some initial error-checking to make sure this routine is being called properly + ! ------------------------------------------------------------------------ + + npts_glc = size(frac_glc) + @assertEqual(npts_glc, size(topo_glc)) + @assertEqual(npts_glc, my_map%get_n_source_points()) + if (present(data_glc)) then + @assertEqual(npts_glc, size(data_glc)) + end if + + ! ------------------------------------------------------------------------ + ! Set optional variables + ! ------------------------------------------------------------------------ + + if (present(data_glc)) then + l_data_glc = data_glc + else + allocate(l_data_glc(npts_glc)) + l_data_glc(:) = 0._r8 + end if + + if (present(icemask_glc)) then + l_icemask_glc = icemask_glc + else + allocate(l_icemask_glc(npts_glc)) + l_icemask_glc(:) = 1._r8 + end if + + ! ------------------------------------------------------------------------ + ! Setup + ! ------------------------------------------------------------------------ + + call glc_elevclass_init(n_elev_classes, elev_class_boundaries) + + call create_aVect_with_data_rows_are_points(this%data_g, & + attr_tags = ['Sg_ice_covered', 'Sg_topo ', 'Sg_icemask ', 'data '], & + data = reshape([frac_glc, topo_glc, l_icemask_glc, l_data_glc], [npts_glc, 4])) + + npts_lnd = my_map%get_n_dest_points() + ! The following assumes that n_elev_classes is 3: + call create_aVect_without_data(this%data_l, lsize = npts_lnd, & + attr_tags = ['Sg_ice_covered00', 'Sg_ice_covered01', 'Sg_ice_covered02', 'Sg_ice_covered03', & + 'Sg_topo00 ', 'Sg_topo01 ', 'Sg_topo02 ', 'Sg_topo03 ', & + 'data00 ', 'data01 ', 'data02 ', 'data03 ']) + + call create_mapper(this%mapper, my_map) + + end subroutine setup_inputs + + subroutine setup_inputs_lnd_fully_outside_static_glc_domain(this, frac_glc, topo_glc, data_glc) + ! Calls setup_inputs with a domain that has 2 lnd cells, 1 glc cell. + ! + ! The lnd cell of interest (#1) is fully outside the static glc domain (i.e., there is + ! no overlap in the mapping weights). The intention is that lnd cell #2 will be + ! ignored in verification; it is only included so that we can set up a non-null map + ! (since simple_map_type won't let you include mapping weights of 0). (Lnd cell #2 + ! can be ignored by setting first_lnd_index_to_verify=1, last_lnd_index_to_verify=1 + ! in the call to verify_data_l_field.) + class(TestMapGlc2lnd), intent(inout) :: this + real(r8), intent(in) :: frac_glc ! frac in the single glc cell + real(r8), intent(in) :: topo_glc ! topo in the single glc cell + real(r8), intent(in), optional :: data_glc ! data in the single glc cell + + real(r8) :: l_data_glc ! local version of data_glc + type(simple_map_type) :: my_map + + l_data_glc = 0._r8 + if (present(data_glc)) then + l_data_glc = data_glc + end if + + my_map = simple_map_type( & + source_indices = [1], & + dest_indices = [2], & + overlap_weights = [1._r8]) + + call this%setup_inputs([frac_glc], [topo_glc], my_map, data_glc = [l_data_glc]) + end subroutine setup_inputs_lnd_fully_outside_static_glc_domain + + subroutine setup_inputs_lnd_partially_outside_static_glc_domain(this, frac_glc, & + topo_glc, data_glc) + ! Calls setup_inputs with a domain that has 1 lnd cell, 1 glc cell. + ! + ! The lnd cell is partially outside the static glc domain, with an overlap of 0.25. + class(TestMapGlc2lnd), intent(inout) :: this + real(r8), intent(in) :: frac_glc ! frac in the single glc cell + real(r8), intent(in) :: topo_glc ! topo in the single glc cell + real(r8), intent(in), optional :: data_glc ! data in the single glc cell + + real(r8) :: l_data_glc ! local version of data_glc + type(simple_map_type) :: my_map + + l_data_glc = 0._r8 + if (present(data_glc)) then + l_data_glc = data_glc + end if + + my_map = simple_map_type( & + source_indices = [1], & + dest_indices = [1], & + overlap_weights = [0.25_r8]) + + call this%setup_inputs([frac_glc], [topo_glc], my_map, data_glc = [l_data_glc]) + end subroutine setup_inputs_lnd_partially_outside_static_glc_domain + + subroutine setup_inputs_lnd_fully_outside_dynamic_glc_domain(this, frac_glc, topo_glc, & + data_glc) + ! Calls setup_inputs with a domain that has 1 lnd cell, 1 glc cell. + ! + ! The lnd cell is entirely within the static glc domain (defined by the mapping + ! file), but entirely outside the dynamic domain (defined by the icemask field). + class(TestMapGlc2lnd), intent(inout) :: this + real(r8), intent(in) :: frac_glc ! frac in the single glc cell + real(r8), intent(in) :: topo_glc ! topo in the single glc cell + real(r8), intent(in), optional :: data_glc ! data in the single glc cell + + real(r8) :: l_data_glc ! local version of data_glc + type(simple_map_type) :: my_map + + l_data_glc = 0._r8 + if (present(data_glc)) then + l_data_glc = data_glc + end if + + my_map = create_simple_map_with_one_source(ndest = 1) + + call this%setup_inputs([frac_glc], [topo_glc], my_map, data_glc = [l_data_glc], & + icemask_glc = [0._r8]) + end subroutine setup_inputs_lnd_fully_outside_dynamic_glc_domain + + subroutine setup_inputs_lnd_partially_outside_dynamic_glc_domain(this, & + frac_glc_in_domain, frac_glc_outside_domain, & + topo_glc_in_domain, topo_glc_outside_domain, & + data_glc_in_domain, data_glc_outside_domain) + ! Calls setup_inputs with a domain that has 1 lnd cell, 2 glc cells. + ! + ! The lnd cell is entirely within the static glc domain (defined by the mapping + ! file), but partially outside the dynamic domain (defined by the icemask field). + ! + ! Specifically: + ! - glc cell 1 (arguments with '_in_domain' suffix) has icemask = 1, overlap = 0.75. + ! - glc cell 2 (arguments with '_outside_domain' suffix) has icemask = 0, overlap = 0.25. + class(TestMapGlc2lnd), intent(inout) :: this + real(r8), intent(in) :: frac_glc_in_domain ! frac in the glc cell with icemask = 1 + real(r8), intent(in) :: frac_glc_outside_domain ! frac in the glc cell with icemask = 0 + real(r8), intent(in) :: topo_glc_in_domain ! topo in the glc cell with icemask = 1 + real(r8), intent(in) :: topo_glc_outside_domain ! topo in the glc cell with icemask = 0 + real(r8), intent(in), optional :: data_glc_in_domain ! data in the glc cell with icemask = 1 + real(r8), intent(in), optional :: data_glc_outside_domain ! data in the glc cell with icemask = 0 + + real(r8) :: l_data_glc_in_domain ! local version of data_glc_in_domain + real(r8) :: l_data_glc_outside_domain ! local version of data_glc_outside_domain + type(simple_map_type) :: my_map + + l_data_glc_in_domain = 0._r8 + if (present(data_glc_in_domain)) then + l_data_glc_in_domain = data_glc_in_domain + end if + l_data_glc_outside_domain = 0._r8 + if (present(data_glc_outside_domain)) then + l_data_glc_outside_domain = data_glc_outside_domain + end if + + my_map = simple_map_type( & + source_indices = [1, 2], & + dest_indices = [1, 1], & + overlap_weights = [0.75_r8, 0.25_r8]) + + call this%setup_inputs( & + [frac_glc_in_domain, frac_glc_outside_domain], & + [topo_glc_in_domain, topo_glc_outside_domain], & + my_map, & + data_glc = [l_data_glc_in_domain, l_data_glc_outside_domain], & + icemask_glc = [1._r8, 0._r8]) + end subroutine setup_inputs_lnd_partially_outside_dynamic_glc_domain + + subroutine run_map_glc2lnd_ec(this, extra_fields) + ! This utility function wraps the call to the map_glc2lnd_ec routine + class(TestMapGlc2lnd), intent(inout) :: this + character(len=*), intent(in), optional :: extra_fields ! extra fields to map + + character(len=:), allocatable :: l_extra_fields ! local version of extra_fields + + l_extra_fields = ' ' + if (present(extra_fields)) then + l_extra_fields = extra_fields + end if + + call map_glc2lnd_ec(g2x_g = this%data_g, & + frac_field = 'Sg_ice_covered', topo_field = 'Sg_topo', icemask_field = 'Sg_icemask', & + extra_fields = l_extra_fields, & + mapper = this%mapper, g2x_l = this%data_l) + + end subroutine run_map_glc2lnd_ec + + subroutine verify_data_l_field(this, fieldname, expected_lnd, message, & + first_lnd_index_to_verify, last_lnd_index_to_verify) + ! Verify one field on the land grid + class(TestMapGlc2lnd), intent(in) :: this + character(len=*), intent(in) :: fieldname ! base name of field (no elev class suffix) + type(lnd_field_type), intent(in) :: expected_lnd(:) + character(len=*), intent(in) :: message + + ! Specify the following if you only want to verify a subset of the total land points. + ! You must either specify both or neither of these. + ! If these are specified, then expected_lnd should be of size + ! (last_lnd_index_to_verify - first_lnd_index_to_verify + 1) + integer, intent(in), optional :: first_lnd_index_to_verify + integer, intent(in), optional :: last_lnd_index_to_verify + + integer :: first, last + integer :: n + logical :: args_okay + character(len=:), allocatable :: ec_string + character(len=:), allocatable :: fieldname_ec + character(len=:), allocatable :: full_message + real(r8), allocatable :: actual_lnd_this_ec(:) + + ! Handle optional arguments + + args_okay = .false. + if (.not. present(first_lnd_index_to_verify) .and. & + .not. present(last_lnd_index_to_verify)) then + first = 1 + last = mct_aVect_lsize(this%data_l) + @assertEqual(size(expected_lnd), last, message=message//': number of points') + args_okay = .true. + else if (present(first_lnd_index_to_verify) .and. & + present(last_lnd_index_to_verify)) then + first = first_lnd_index_to_verify + last = last_lnd_index_to_verify + @assertEqual(size(expected_lnd), last-first+1, message=message//': number of points') + args_okay = .true. + end if + @assertTrue(args_okay, message=message//': optional arguments') + + ! Do the verification + do n = 0, n_elev_classes + ec_string = glc_elevclass_as_string(n) + fieldname_ec = fieldname // ec_string + actual_lnd_this_ec = aVect_exportRattr(this%data_l, fieldname_ec) + full_message = message//': elevation class ' // ec_string + @assertEqual(expected_lnd(:)%data(n), actual_lnd_this_ec(first:last), message=full_message, tolerance=tol) + end do + end subroutine verify_data_l_field + + subroutine set_topo_to_mean_elevation_virtual(topo_data) + ! Sets topo_data to glc_mean_elevation_virtual for all grid cells and all elevation + ! classes + type(lnd_field_type), intent(out) :: topo_data(:) + + integer :: n + + do n = 0, n_elev_classes + topo_data(:)%data(n) = glc_mean_elevation_virtual(n) + end do + end subroutine set_topo_to_mean_elevation_virtual + + ! ======================================================================== + ! Actual tests + ! ======================================================================== + + ! ------------------------------------------------------------------------ + ! Tests of mapped ice fraction + ! ------------------------------------------------------------------------ + + @Test + subroutine test_mapGlc2lndEC_frac_with_EC0(this) + ! Do a test of the map_glc2lnd_ec routine with only an elevation class 0 source + ! point. Check the mapped frac. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(lnd_field_type) :: frac_lnd_expected(nlnd) + type(simple_map_type) :: my_map + real(r8), parameter :: irrelevant_topo = 125._r8 ! irrelevant for this test + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + frac_glc(1) = 0._r8 + topo_glc(1) = irrelevant_topo + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + frac_lnd_expected(1)%data(:) = 0._r8 + frac_lnd_expected(1)%data(0) = 1._r8 + + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_with_EC0: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_with_EC0 + + @Test + subroutine test_mapGlc2lndEC_frac_with_EC2(this) + ! Do a test of the map_glc2lnd_ec routine with only an elevation class 2 source + ! point. Check the mapped frac. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(lnd_field_type) :: frac_lnd_expected(nlnd) + type(simple_map_type) :: my_map + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + frac_glc(1) = 1._r8 + topo_glc(1) = 125._r8 + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + frac_lnd_expected(1)%data(:) = 0._r8 + frac_lnd_expected(1)%data(2) = 1._r8 + + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_with_EC2: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_with_EC2 + + @Test + subroutine test_mapGlc2lndEC_frac_with_allECs(this) + ! Do a test of the map_glc2lnd_ec routine with source points from each elevation + ! class. Check the mapped frac. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 4 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(lnd_field_type) :: frac_lnd_expected(nlnd) + type(simple_map_type) :: my_map + real(r8), parameter :: irrelevant_topo = 125._r8 + + ! Setup + + frac_glc(:) = [1._r8, 1._r8, 1._r8, 0._r8] + topo_glc(:) = [225._r8, 125._r8, 25._r8, irrelevant_topo] + + my_map = simple_map_type( & + source_indices = [1, 2, 3, 4], & + dest_indices = [1, 1, 1, 1], & + overlap_weights = [0.4_r8, 0.3_r8, 0.2_r8, 0.1_r8]) + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + frac_lnd_expected(1)%data(:) = [0.1_r8, 0.2_r8, 0.3_r8, 0.4_r8] + + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_with_allECs: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_with_allECs + + @Test + subroutine test_mapGlc2lndEC_frac_fully_outside_static_domain(this) + ! Test mapped fraction with a land cell that is fully outside the static GLC domain + ! (i.e., mapping weight is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: frac_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_static_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + frac_lnd_expected(1)%data(:) = 0._r8 + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_fully_outside_static_domain: Sg_ice_covered', & + first_lnd_index_to_verify = 1, last_lnd_index_to_verify = 1) + end subroutine test_mapGlc2lndEC_frac_fully_outside_static_domain + + @Test + subroutine test_mapGlc2lndEC_frac_partially_outside_static_domain(this) + ! Test mapped fraction with a land cell that is partially outside the static GLC domain + ! (i.e., mapping weight is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: frac_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_static_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + ! Note that we expect the land cell to end up fully covered with ice, despite being + ! partially outside the GLC domain. This is achieved by mapping with normalization. + frac_lnd_expected(1)%data(:) = [0._r8, 0._r8, 1._r8, 0._r8] + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_partially_outside_static_domain: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_partially_outside_static_domain + + @Test + subroutine test_mapGlc2lndEC_frac_fully_outside_dynamic_domain(this) + ! Test mapped fraction with a land cell that is fully outside the dynamic GLC domain + ! (i.e., icemask is 0) + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: frac_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_dynamic_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + frac_lnd_expected(1)%data(:) = 0._r8 + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_fully_outside_dynamic_domain: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_fully_outside_dynamic_domain + + @Test + subroutine test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_diffECs(this) + ! Test mapped fraction with a land cell that is partially outside the dynamic GLC + ! domain, with two GLC points in different elevation classes + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: frac_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_dynamic_glc_domain( & + frac_glc_in_domain = 1._r8, frac_glc_outside_domain = 1._r8, & + topo_glc_in_domain = 125._r8, topo_glc_outside_domain = 25._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + frac_lnd_expected(1)%data(:) = [0._r8, 0._r8, 1._r8, 0._r8] + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_diffECs: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_diffECs + + @Test + subroutine test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_sameEC(this) + ! Test mapped fraction with a land cell that is partially outside the dynamic GLC + ! domain, with two GLC points in the same elevation class + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: frac_lnd_expected(1) + + ! Setup + ! Note that we are specifying fracs that are between 0 and 1. This situation + ! currently won't arise in practice, but using a fraction of 1 for both glc cells + ! doesn't have much testing power for this case: we couldn't tell if the point + ! outside the mask is being ignored or not. + call this%setup_inputs_lnd_partially_outside_dynamic_glc_domain( & + frac_glc_in_domain = 0.6_r8, frac_glc_outside_domain = 0.4_r8, & + topo_glc_in_domain = 125._r8, topo_glc_outside_domain = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + frac_lnd_expected(1)%data(:) = [0.4_r8, 0._r8, 0.6_r8, 0._r8] + call this%verify_data_l_field(fieldname='Sg_ice_covered', expected_lnd=frac_lnd_expected, & + message = 'test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_sameEC: Sg_ice_covered') + end subroutine test_mapGlc2lndEC_frac_partially_outside_dynamic_domain_sameEC + + ! ------------------------------------------------------------------------ + ! Tests of mapped topo + ! ------------------------------------------------------------------------ + + @Test + subroutine test_mapGlc2lndEC_topo_with_EC0(this) + ! Do a test of the map_glc2lnd_ec routine with only an elevation class 0 source + ! point. Check the mapped topo. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(simple_map_type) :: my_map + real(r8) :: topo_expected_ec0(nlnd) + real(r8), allocatable :: topo_actual_ec0(:) + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + frac_glc(1) = 0._r8 + topo_glc(1) = 125._r8 + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + topo_expected_ec0(1) = topo_glc(1) + topo_actual_ec0 = aVect_exportRattr(this%data_l, 'Sg_topo00') + @assertEqual(topo_expected_ec0, topo_actual_ec0) + end subroutine test_mapGlc2lndEC_topo_with_EC0 + + @Test + subroutine test_mapGlc2lndEC_topo_with_EC2(this) + ! Do a test of the map_glc2lnd_ec routine with only an elevation class 2 source + ! point. Check the mapped topo. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(simple_map_type) :: my_map + real(r8) :: topo_expected_ec2(nlnd) + real(r8), allocatable :: topo_actual_ec2(:) + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + frac_glc(1) = 1._r8 + topo_glc(1) = 125._r8 + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + topo_expected_ec2(1) = topo_glc(1) + topo_actual_ec2 = aVect_exportRattr(this%data_l, 'Sg_topo02') + @assertEqual(topo_expected_ec2, topo_actual_ec2) + end subroutine test_mapGlc2lndEC_topo_with_EC2 + + @Test + subroutine test_mapGlc2lndEC_topo_virtual_elevation_class(this) + ! Do a test of the map_glc2lnd_ec routine, checking mapped topo for virtual elevation + ! classes. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(simple_map_type) :: my_map + type(lnd_field_type) :: topo_lnd_expected(nlnd) + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + ! We have a non-virtual elevation class 2; all other elevation classes (including + ! bare land) are virtual. + frac_glc(1) = 1._r8 + topo_glc(1) = 125._r8 + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + topo_lnd_expected(1)%data(0) = glc_mean_elevation_virtual(0) + topo_lnd_expected(1)%data(1) = glc_mean_elevation_virtual(1) + topo_lnd_expected(1)%data(2) = topo_glc(1) ! non-virtual + topo_lnd_expected(1)%data(3) = glc_mean_elevation_virtual(3) + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_virtual_elevation_class: Sg_topo') + + end subroutine test_mapGlc2lndEC_topo_virtual_elevation_class + + @Test + subroutine test_mapGlc2lndEC_topo_virtual_elevation_class_multiple_points(this) + ! Do a test of the map_glc2lnd_ec routine, checking mapped topo for virtual elevation + ! classes, with multiple points (to ensure that real points aren't getting assigned + ! the elevation from virtual elevation classes). + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 2 + integer, parameter :: nglc = 2 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + type(simple_map_type) :: my_map + type(lnd_field_type) :: topo_lnd_expected(nlnd) + integer :: n + + ! Setup + + frac_glc(:) = [1._r8, 1._r8] + topo_glc(:) = [125._r8, 225._r8] + + my_map = simple_map_type( & + source_indices = [1, 2], & + dest_indices = [1, 2], & + overlap_weights = [1._r8, 1._r8]) + + call this%setup_inputs(frac_glc, topo_glc, my_map) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + ! But set non-virtual points: + topo_lnd_expected(1)%data(2) = 125._r8 + topo_lnd_expected(2)%data(3) = 225._r8 + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_virtual_elevation_class_multiple_points: Sg_topo') + + end subroutine test_mapGlc2lndEC_topo_virtual_elevation_class_multiple_points + + @Test + subroutine test_mapGlc2lndEC_topo_fully_outside_static_domain(this) + ! Test mapped topo with a land cell that is fully outside the static GLC domain + ! (i.e., mapping weight is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_static_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_fully_outside_static_domain: Sg_topo', & + first_lnd_index_to_verify = 1, last_lnd_index_to_verify = 1) + end subroutine test_mapGlc2lndEC_topo_fully_outside_static_domain + + @Test + subroutine test_mapGlc2lndEC_topo_partially_outside_static_domain(this) + ! Test mapped topo with a land cell that is partially outside the static GLC domain + ! (i.e., mapping weight is 0). + ! + ! Note: the logic is the same in this respect for topo and any other data field, so + ! this can also be considered to be a test for other data fields, when a land cell is + ! partially outside the static GLC domain. + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_static_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + topo_lnd_expected(1)%data(2) = 125._r8 + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_partially_outside_static_domain: Sg_topo') + end subroutine test_mapGlc2lndEC_topo_partially_outside_static_domain + + @Test + subroutine test_mapGlc2lndEC_topo_fully_outside_dynamic_domain(this) + ! Test mapped topo with a land cell that is fully outside the dynamic GLC domain + ! (i.e., icemask is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_dynamic_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_fully_outside_dynamic_domain: Sg_topo') + end subroutine test_mapGlc2lndEC_topo_fully_outside_dynamic_domain + + @Test + subroutine test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_sameEC(this) + ! Test mapped topo with a land cell that is partially outside the dynamic GLC + ! domain, with two GLC points in the same elevation class + ! + ! Note: the logic is the same in this respect for topo and any other data field, so + ! this can also be considered to be a test for other data fields, when a land cell is + ! partially outside the dynamic GLC domain. + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_dynamic_glc_domain( & + frac_glc_in_domain = 1._r8, frac_glc_outside_domain = 1._r8, & + topo_glc_in_domain = 125._r8, topo_glc_outside_domain = 175._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + topo_lnd_expected(1)%data(2) = 125._r8 + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_sameEC: Sg_topo') + end subroutine test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_sameEC + + @Test + subroutine test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_diffECs(this) + ! Test mapped topo with a land cell that is partially outside the dynamic GLC + ! domain, with two GLC points in different elevation classes + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_dynamic_glc_domain( & + frac_glc_in_domain = 1._r8, frac_glc_outside_domain = 1._r8, & + topo_glc_in_domain = 125._r8, topo_glc_outside_domain = 25._r8) + + ! Exercise + call this%run_map_glc2lnd_ec() + + ! Verify + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + topo_lnd_expected(1)%data(2) = 125._r8 + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_diffECs: Sg_topo') + end subroutine test_mapGlc2lndEC_topo_partially_outside_dynamic_domain_diffECs + + @Test + subroutine test_mapGlc2lndEC_topo_multiple_sources(this) + ! Test mapped topo with multiple source points, with a variety of ice masks and + ! elevation classes. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nglc = 6 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + real(r8) :: icemask(nglc) + real(r8) :: overlap(nglc) + type(simple_map_type) :: my_map + type(lnd_field_type) :: topo_lnd_expected(1) + + ! Setup + + ! EC2 , EC2-fractional, EC0 , MASK0-FRAC1, MASK0-FRAC0, EC3 + icemask(:) = [1._r8 , 1._r8 , 1._r8 , 0._r8 , 0._r8 , 1._r8] + frac_glc(:) = [1._r8 , 0.8_r8 , 0._r8 , 1._r8 , 0._r8 , 1._r8] + topo_glc(:) = [110._r8, 120._r8 , 130._r8, 140._r8 , 150._r8 , 210._r8] + overlap(:) = [0.2_r8 , 0.2_r8 , 0.2_r8 , 0.2_r8 , 0.1_r8 , 0.1_r8] + + my_map = simple_map_type( & + source_indices = [1, 2, 3, 4, 5, 6], & + dest_indices = [1, 1, 1, 1, 1, 1], & + overlap_weights = overlap) + + call this%setup_inputs(frac_glc, topo_glc, my_map, icemask_glc = icemask) + + ! Exercise + + call this%run_map_glc2lnd_ec() + + ! Verify + + call set_topo_to_mean_elevation_virtual(topo_lnd_expected) + topo_lnd_expected(1)%data(0) = (130._r8 + 120._r8 * 0.2_r8) / 1.2_r8 + topo_lnd_expected(1)%data(2) = (110._r8 + 120._r8 * 0.8_r8) / 1.8_r8 + topo_lnd_expected(1)%data(3) = 210._r8 + call this%verify_data_l_field(fieldname='Sg_topo', expected_lnd=topo_lnd_expected, & + message = 'test_mapGlc2lndEC_topo_multiple_sources: Sg_topo') + end subroutine test_mapGlc2lndEC_topo_multiple_sources + + ! ------------------------------------------------------------------------ + ! Tests of mapped data field + ! ------------------------------------------------------------------------ + + @Test + subroutine test_mapGlc2lndEC_data(this) + ! Do a test of the map_glc2lnd_ec routine with only an elevation class 2 source + ! point. Check the mapped data field. Point is to make sure that extra fields + ! (besides frac and topo) get mapped properly. + class(TestMapGlc2lnd), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nglc = 1 + real(r8) :: frac_glc(nglc) + real(r8) :: topo_glc(nglc) + real(r8) :: data_glc(nglc) + type(simple_map_type) :: my_map + real(r8) :: data_expected_ec2(nlnd) + real(r8), allocatable :: data_actual_ec2(:) + + ! Setup + + my_map = create_simple_map_with_one_source(ndest = nlnd) + + frac_glc(1) = 1._r8 + topo_glc(1) = 125._r8 + data_glc(1) = 12345._r8 + + call this%setup_inputs(frac_glc, topo_glc, my_map, data_glc=data_glc) + + ! Exercise + + call this%run_map_glc2lnd_ec(extra_fields = 'data') + + ! Verify + + data_expected_ec2(1) = data_glc(1) + data_actual_ec2 = aVect_exportRattr(this%data_l, 'data02') + @assertEqual(data_expected_ec2, data_actual_ec2) + end subroutine test_mapGlc2lndEC_data + + @Test + subroutine test_mapGlc2lndEC_data_fully_outside_static_domain(this) + ! Test mapped data with a land cell that is fully outside the static GLC domain + ! (i.e., mapping weight is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: data_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_static_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8, data_glc = 12345._r8) + + ! Exercise + call this%run_map_glc2lnd_ec(extra_fields = 'data') + + ! Verify + data_lnd_expected(1)%data(:) = 0._r8 + call this%verify_data_l_field(fieldname='data', expected_lnd=data_lnd_expected, & + message = 'test_mapGlc2lndEC_data_fully_outside_static_domain: data', & + first_lnd_index_to_verify = 1, last_lnd_index_to_verify = 1) + end subroutine test_mapGlc2lndEC_data_fully_outside_static_domain + + @Test + subroutine test_mapGlc2lndEC_data_fully_outside_dynamic_domain(this) + ! Test mapped data with a land cell that is fully outside the dynamic GLC domain + ! (i.e., icemask is 0). + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: data_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_fully_outside_dynamic_glc_domain( & + frac_glc = 1._r8, topo_glc = 125._r8, data_glc = 12345._r8) + + ! Exercise + call this%run_map_glc2lnd_ec(extra_fields = 'data') + + ! Verify + data_lnd_expected(1)%data(:) = 0._r8 + call this%verify_data_l_field(fieldname='data', expected_lnd=data_lnd_expected, & + message = 'test_mapGlc2lndEC_data_fully_outside_dynamic_domain: data') + end subroutine test_mapGlc2lndEC_data_fully_outside_dynamic_domain + + @Test + subroutine test_mapGlc2lndEC_data_partially_outside_dynamic_domain_diffECs(this) + ! Test mapped data with a land cell that is partially outside the dynamic GLC + ! domain, with two GLC points in different elevation classes + class(TestMapGlc2lnd), intent(inout) :: this + type(lnd_field_type) :: data_lnd_expected(1) + + ! Setup + call this%setup_inputs_lnd_partially_outside_dynamic_glc_domain( & + frac_glc_in_domain = 1._r8, frac_glc_outside_domain = 1._r8, & + topo_glc_in_domain = 125._r8, topo_glc_outside_domain = 25._r8, & + data_glc_in_domain = 12345._r8, data_glc_outside_domain = 6789._r8) + + ! Exercise + call this%run_map_glc2lnd_ec(extra_fields = 'data') + + ! Verify + data_lnd_expected(1)%data(:) = [0._r8, 0._r8, 12345._r8, 0._r8] + call this%verify_data_l_field(fieldname='data', expected_lnd=data_lnd_expected, & + message = 'test_mapGlc2lndEC_data_partially_outside_dynamic_domain_diffECs: data') + end subroutine test_mapGlc2lndEC_data_partially_outside_dynamic_domain_diffECs + +end module test_map_glc2lnd diff --git a/driver-mct/unit_test/map_lnd2rof_irrig_test/CMakeLists.txt b/driver-mct/unit_test/map_lnd2rof_irrig_test/CMakeLists.txt new file mode 100644 index 000000000000..199341061ceb --- /dev/null +++ b/driver-mct/unit_test/map_lnd2rof_irrig_test/CMakeLists.txt @@ -0,0 +1,8 @@ +set (pfunit_sources + test_map_lnd2rof_irrig.pf + ) + +create_pFUnit_test(map_lnd2rof_irrig map_lnd2rof_irrig_exe + "${pfunit_sources}" "") + +target_link_libraries(map_lnd2rof_irrig_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/map_lnd2rof_irrig_test/test_map_lnd2rof_irrig.pf b/driver-mct/unit_test/map_lnd2rof_irrig_test/test_map_lnd2rof_irrig.pf new file mode 100644 index 000000000000..f50bf8f3b1a7 --- /dev/null +++ b/driver-mct/unit_test/map_lnd2rof_irrig_test/test_map_lnd2rof_irrig.pf @@ -0,0 +1,242 @@ +module test_map_lnd2rof_irrig + + ! Tests of map_lnd2rof_irrig_mod + +#include "shr_assert.h" + use pfunit_mod + use map_lnd2rof_irrig_mod + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod, only : errMsg => shr_log_errMsg + use mct_mod, only : mct_aVect, mct_aVect_clean, mct_aVect_lsize + use seq_map_type_mod, only : seq_map + use mct_wrapper_mod, only : mct_init, mct_clean + use avect_wrapper_mod + use simple_map_mod + use create_mapper_mod + + implicit none + + @TestCase + type, extends(TestCase) :: TestMapL2RIrrig + type(mct_aVect) :: l2r_l ! data on the lnd (source) grid + type(mct_aVect) :: l2r_r ! data on the rof (destination) grid + type(mct_aVect) :: r2x_r ! auxiliary data on the rof grid + type(seq_map) :: mapper_Fl2r + type(seq_map) :: mapper_Fr2l + contains + procedure :: setUp + procedure :: tearDown + procedure :: setup_inputs + procedure :: run_map_lnd2rof_irrig ! wrapper to the SUT + end type TestMapL2RIrrig + + real(r8), parameter :: tol = 1.e-13_r8 + + character(len=*), parameter :: irrig_flux_field = 'irrig' + + character(len=*), parameter, private :: sourcefile = & + __FILE__ +contains + + ! ======================================================================== + ! Utility routines + ! ======================================================================== + + subroutine setUp(this) + class(TestMapL2RIrrig), intent(inout) :: this + + call mct_init() + end subroutine setUp + + subroutine tearDown(this) + class(TestMapL2RIrrig), intent(inout) :: this + + call clean_mapper(this%mapper_Fl2r) + call clean_mapper(this%mapper_Fr2l) + call mct_aVect_clean(this%l2r_l) + call mct_aVect_clean(this%l2r_r) + call mct_aVect_clean(this%r2x_r) + call mct_clean() + end subroutine tearDown + + subroutine setup_inputs(this, irrig_l, volr_r, map_l2r, map_r2l) + ! This utility function sets up inputs that are needed for the map_lnd2rof_irrig call + class(TestMapL2RIrrig), intent(inout) :: this + real(r8), intent(in) :: irrig_l(:) ! irrigation on the land grid + real(r8), intent(in) :: volr_r(:) ! river volume on the rof grid + type(simple_map_type), intent(in) :: map_l2r + type(simple_map_type), intent(in) :: map_r2l + + integer :: nlnd + integer :: nrof + character(len=*), parameter :: volr_field = 'Flrr_volrmch' + + nlnd = map_l2r%get_n_source_points() + nrof = map_l2r%get_n_dest_points() + call shr_assert(map_r2l%get_n_dest_points() == nlnd, file=sourcefile, line=__LINE__) + call shr_assert(map_r2l%get_n_source_points() == nrof, file=sourcefile, line=__LINE__) + call shr_assert(size(irrig_l) == nlnd, file=sourcefile, line=__LINE__) + call shr_assert(size(volr_r) == nrof, file=sourcefile, line=__LINE__) + + call create_aVect_with_data_rows_are_points(this%l2r_l, & + attr_tags = [irrig_flux_field], & + data = reshape(irrig_l, [nlnd, 1])) + + call create_aVect_without_data(this%l2r_r, attr_tags = [irrig_flux_field], lsize = nrof) + + call create_aVect_with_data_rows_are_points(this%r2x_r, & + attr_tags = [volr_field], & + data = reshape(volr_r, [nrof, 1])) + + call create_mapper(this%mapper_Fl2r, map_l2r) + call create_mapper(this%mapper_Fr2l, map_r2l) + + end subroutine setup_inputs + + subroutine run_map_lnd2rof_irrig(this) + ! This utility function wraps the call to the map_lnd2rof_irrig routine + ! + ! It uses an avwts_s set to 1 everywhere + class(TestMapL2RIrrig), intent(inout) :: this + + integer :: nlnd + real(r8), allocatable :: avwts(:) + type(mct_aVect) :: avwts_s + character(len=*), parameter :: avwtsfld_s = 'my_avwtsfld' + + ! Set up avwts_s with weights set to 1 everywhere + nlnd = mct_aVect_lsize(this%l2r_l) + allocate(avwts(nlnd)) + avwts(:) = 1._r8 + call create_aVect_with_data_rows_are_points(avwts_s, & + attr_tags = [avwtsfld_s], & + data = reshape(avwts, [nlnd, 1])) + + ! Do the main SUT call + call map_lnd2rof_irrig( & + l2r_l = this%l2r_l, & + r2x_r = this%r2x_r, & + irrig_flux_field = irrig_flux_field, & + avwts_s = avwts_s, & + avwtsfld_s = avwtsfld_s, & + mapper_Fl2r = this%mapper_Fl2r, & + mapper_Fr2l = this%mapper_Fr2l, & + l2r_r = this%l2r_r) + + ! Clean up + deallocate(avwts) + call mct_aVect_clean(avwts_s) + end subroutine run_map_lnd2rof_irrig + + ! ======================================================================== + ! Actual tests + ! ======================================================================== + + @Test + subroutine test_standardCase_oneLand_twoRof(this) + ! Standard case with one land (source) cell and two rof (destination) cells + class(TestMapL2RIrrig), intent(inout) :: this + integer, parameter :: nlnd = 1 + integer, parameter :: nrof = 2 + real(r8), parameter :: irrig_l(nlnd) = [100._r8] + real(r8), parameter :: volr_r(nrof) = [1._r8, 3._r8] + real(r8) :: irrig_r(nrof) + real(r8) :: expected_volr_l + real(r8) :: expected_irrig_r(nrof) + real(r8) :: sum_irrig_r + type(simple_map_type) :: map_l2r + type(simple_map_type) :: map_r2l + + ! Setup + map_l2r = create_simple_map_with_one_source(ndest = nrof) + map_r2l = simple_map_type( & + source_indices = [1, 2], & + dest_indices = [1, 1], & + overlap_weights = [0.4_r8, 0.6_r8]) + call this%setup_inputs( & + irrig_l = irrig_l, & + volr_r = volr_r, & + map_l2r = map_l2r, & + map_r2l = map_r2l) + + ! Exercise + call this%run_map_lnd2rof_irrig() + + ! Verify + irrig_r = aVect_exportRattr(this%l2r_r, irrig_flux_field) + expected_volr_l = 0.4_r8 * 1._r8 + 0.6_r8 * 3._r8 + expected_irrig_r(1) = irrig_l(1) * 1._r8 / expected_volr_l + expected_irrig_r(2) = irrig_l(1) * 3._r8 / expected_volr_l + @assertEqual(expected_irrig_r, irrig_r, tolerance=tol) + ! Also make sure this is conservative: + sum_irrig_r = 0.4_r8*irrig_r(1) + 0.6_r8*irrig_r(2) + @assertEqual(irrig_l(1), sum_irrig_r, tolerance=tol) + end subroutine test_standardCase_oneLand_twoRof + + @Test + subroutine test_zero_and_negative(this) + ! This tests the handling of rof cells with 0 or negative volr. It includes two land + ! (source) points, to ensure that each land cell gets its own handling and to ensure + ! that R2 (which overlaps L1 and L2) gets the appropriate value. + ! + ! This has the following setup: + ! + ! L (2 cells): 111222 + ! R (3 cells): 112233 + ! R1 has volr = 0 + ! R2 has volr = -10 + ! R3 has volr = 2 + ! + ! Then Irrig_L(1) should be mapped evenly to R1 and R2 (regular mapping); Irrig_L(2) + ! should be mapped entirely to R3 (because R2 should be reset to 0, then it should use + ! normalized mapping). + class(TestMapL2RIrrig), intent(inout) :: this + integer, parameter :: nlnd = 2 + integer, parameter :: nrof = 3 + real(r8), parameter :: irrig_l(nlnd) = [10._r8, 100._r8] + real(r8), parameter :: volr_r(nrof) = [0._r8, -10._r8, 2._r8] + real(r8) :: irrig_r(nrof) + real(r8) :: expected_irrig_r2 + type(simple_map_type) :: map_l2r + type(simple_map_type) :: map_r2l + real(r8) :: sum_irrig_l + real(r8) :: sum_irrig_r + + ! Setup + map_l2r = simple_map_type( & + source_indices = [1, 1, 2, 2], & + dest_indices = [1, 2, 2, 3], & + overlap_weights = [1._r8, 0.5_r8, 0.5_r8, 1._r8]) + + map_r2l = simple_map_type( & + source_indices = [1, 2, 2, 3], & + dest_indices = [1, 1, 2, 2], & + overlap_weights = [2._r8/3._r8, 1._r8/3._r8, 1._r8/3._r8, 2._r8/3._r8]) + + call this%setup_inputs( & + irrig_l = irrig_l, & + volr_r = volr_r, & + map_l2r = map_l2r, & + map_r2l = map_r2l) + + ! Exercise + call this%run_map_lnd2rof_irrig() + + ! Verify + irrig_r = aVect_exportRattr(this%l2r_r, irrig_flux_field) + ! L1 is mapped without normalization, so the flux in R1 is simply the flux in L1 + @assertEqual(irrig_l(1), irrig_r(1), tolerance=tol) + ! L2 is mapped with normalization; all of its irrigation goes into R3 + @assertEqual(irrig_l(2) * 3._r8/2._r8, irrig_r(3), tolerance=tol) + ! R2 overlaps L1 and L2, with 50% in each. From L1 it gets the irrigation flux mapped + ! directly; from L2 it gets 0 (since L2 is mapped with normalization, and R2's volr < + ! 0). + @assertEqual(irrig_l(1) * 0.5_r8, irrig_r(2), tolerance=tol) + ! Also make sure this is conservative + sum_irrig_l = 3._r8 * irrig_l(1) + 3._r8 * irrig_l(2) + sum_irrig_r = 2._r8 * irrig_r(1) + 2._r8 * irrig_r(2) + 2._r8 * irrig_r(3) + @assertEqual(sum_irrig_l, sum_irrig_r) + + end subroutine test_zero_and_negative + +end module test_map_lnd2rof_irrig diff --git a/driver-mct/unit_test/seq_map_test/CMakeLists.txt b/driver-mct/unit_test/seq_map_test/CMakeLists.txt new file mode 100644 index 000000000000..6e12c40dda03 --- /dev/null +++ b/driver-mct/unit_test/seq_map_test/CMakeLists.txt @@ -0,0 +1,4 @@ +create_pFUnit_test(seq_map seq_map_exe + "test_seq_map.pf" "") + +target_link_libraries(seq_map_exe ${DRV_UNIT_TEST_LIBS}) diff --git a/driver-mct/unit_test/seq_map_test/test_seq_map.pf b/driver-mct/unit_test/seq_map_test/test_seq_map.pf new file mode 100644 index 000000000000..47d05a44f77b --- /dev/null +++ b/driver-mct/unit_test/seq_map_test/test_seq_map.pf @@ -0,0 +1,136 @@ +module test_seq_map + + ! Tests of seq_map_mod + + use pfunit_mod + use seq_map_mod + use seq_map_type_mod + use mct_mod + use mct_wrapper_mod, only : mct_init, mct_clean + use avect_wrapper_mod + use simple_map_mod + use create_mapper_mod + use shr_kind_mod, only : r8 => shr_kind_r8 + + implicit none + + + real(r8), parameter :: tol = 1.e-13_r8 + + @TestCase + type, extends(TestCase) :: TestSeqMap + type(seq_map) :: mapper + type(mct_aVect) :: av_s ! data on the source grid + type(mct_aVect) :: av_d ! data on the destination grid + contains + procedure :: setUp + procedure :: tearDown + end type TestSeqMap + +contains + + subroutine setUp(this) + class(TestSeqMap), intent(inout) :: this + + call mct_init() + end subroutine setUp + + subroutine tearDown(this) + class(TestSeqMap), intent(inout) :: this + + call clean_mapper(this%mapper) + call mct_aVect_clean(this%av_s) + call mct_aVect_clean(this%av_d) + call mct_clean() + end subroutine tearDown + + @Test + subroutine test_seqMapMap_1DestPt_returnsCorrectAV(this) + class(TestSeqMap), intent(inout) :: this + integer, parameter :: npts_source = 3 + integer, parameter :: npts_dest = 1 + real(r8), parameter :: data_source(npts_source) = [1._r8, 11._r8, 12._r8] + real(r8) :: expected_data(npts_dest) + real(r8), allocatable :: actual_data(:) + type(simple_map_type) :: my_map + + ! Setup + + ! Set up an area-conservative mapping that looks like the following: + ! Source: AABC + ! Dest: 1111 + ! i.e., there is a single destination grid cell, which is overlapped by 3 source grid + ! cells: A (50%), B (25%), C (25%) + + ! Set up attribute vectors + call create_aVect_with_data_rows_are_points(this%av_s, & + attr_tags = ['data'], & + data = reshape(data_source, [npts_source,1])) + call create_aVect_without_data(this%av_d, & + attr_tags = ['data'], & + lsize = npts_dest) + + ! Set up mapper. This is an area-conservative remapping. + my_map = simple_map_type( & + source_indices = [1, 2, 3], & + dest_indices = [1, 1, 1], & + overlap_weights = [0.5_r8, 0.25_r8, 0.25_r8]) + call create_mapper(this%mapper, my_map) + + ! Exercise + call seq_map_map(this%mapper, this%av_s, this%av_d) + + ! Verify + + actual_data = aVect_exportRattr(this%av_d, 'data') + expected_data(1) = & + 0.5_r8 * data_source(1) + & + 0.25_r8 * data_source(2) + & + 0.25_r8 * data_source(3) + @assertEqual(expected_data, actual_data, tolerance=tol) + end subroutine test_seqMapMap_1DestPt_returnsCorrectAV + + @Test + subroutine test_seqMapMap_2DestPt_returnsCorrectAV(this) + class(TestSeqMap), intent(inout) :: this + integer, parameter :: npts_source = 3 + integer, parameter :: npts_dest = 2 + real(r8), parameter :: data_source(npts_source) = [1._r8, 11._r8, 12._r8] + real(r8) :: expected_data(npts_dest) + real(r8), allocatable :: actual_data(:) + type(simple_map_type) :: my_map + + ! Setup + + ! Set up attribute vectors + call create_aVect_with_data_rows_are_points(this%av_s, & + attr_tags = ['data'], & + data = reshape(data_source, [npts_source,1])) + call create_aVect_without_data(this%av_d, & + attr_tags = ['data'], & + lsize = npts_dest) + + ! Set up mapper. This is an area-conservative remapping. + my_map = simple_map_type( & + source_indices = [1, 2, 3, 2, 3], & + dest_indices = [1, 1, 1, 2, 2], & + overlap_weights = [0.5_r8, 0.25_r8, 0.25_r8, 0.5_r8, 0.5_r8]) + call create_mapper(this%mapper, my_map) + + ! Exercise + call seq_map_map(this%mapper, this%av_s, this%av_d) + + ! Verify + + actual_data = aVect_exportRattr(this%av_d, 'data') + expected_data(1) = & + 0.5_r8 * data_source(1) + & + 0.25_r8 * data_source(2) + & + 0.25_r8 * data_source(3) + expected_data(2) = & + 0.5_r8 * data_source(2) + & + 0.5_r8 * data_source(3) + @assertEqual(expected_data, actual_data, tolerance=tol) + end subroutine test_seqMapMap_2DestPt_returnsCorrectAV + +end module test_seq_map diff --git a/driver-mct/unit_test/stubs/CMakeLists.txt b/driver-mct/unit_test/stubs/CMakeLists.txt new file mode 100644 index 000000000000..572c31660577 --- /dev/null +++ b/driver-mct/unit_test/stubs/CMakeLists.txt @@ -0,0 +1,5 @@ +list(APPEND drv_sources + seq_timemgr_mod.F90 + ) + +sourcelist_to_parent(drv_sources) \ No newline at end of file diff --git a/driver-mct/unit_test/stubs/seq_timemgr_mod.F90 b/driver-mct/unit_test/stubs/seq_timemgr_mod.F90 new file mode 100644 index 000000000000..f88a96d2da8c --- /dev/null +++ b/driver-mct/unit_test/stubs/seq_timemgr_mod.F90 @@ -0,0 +1,19 @@ +module seq_timemgr_mod + + ! Stub for routines from seq_timemgr_mod that are needed by other modules built by the + ! unit tests. + + implicit none + private + + public :: seq_timemgr_pause_active + +contains + + logical function seq_timemgr_pause_active() + ! Stub for seq_timemgr_pause_active - always returns .false. + + seq_timemgr_pause_active = .false. + end function seq_timemgr_pause_active + +end module seq_timemgr_mod diff --git a/driver-mct/unit_test/utils/CMakeLists.txt b/driver-mct/unit_test/utils/CMakeLists.txt new file mode 100644 index 000000000000..ca74c7f01810 --- /dev/null +++ b/driver-mct/unit_test/utils/CMakeLists.txt @@ -0,0 +1,8 @@ +list(APPEND drv_sources + avect_wrapper_mod.F90 + create_mapper_mod.F90 + mct_wrapper_mod.F90 + simple_map_mod.F90 + ) + +sourcelist_to_parent(drv_sources) \ No newline at end of file diff --git a/driver-mct/unit_test/utils/avect_wrapper_mod.F90 b/driver-mct/unit_test/utils/avect_wrapper_mod.F90 new file mode 100644 index 000000000000..e1bc78015a2b --- /dev/null +++ b/driver-mct/unit_test/utils/avect_wrapper_mod.F90 @@ -0,0 +1,180 @@ +module avect_wrapper_mod + ! This module supports building attribute vectors for use in unit tests, as well as + ! performing other operations on attribute vectors. + + use shr_kind_mod, only : r8 => shr_kind_r8 + use mct_mod + + implicit none + private + save + + + ! The following two routines are the same, except for the meaning of the two dimensions + ! of the 'data' array + public :: create_aVect_with_data_rows_are_points ! creates an attribute vector with a given set of real-valued fields, and fills it with the given data + public :: create_aVect_with_data_rows_are_fields ! creates an attribute vector with a given set of real-valued fields, and fills it with the given data + + public :: create_aVect_without_data ! creates an attribute vector with a given set of real-valued fields + public :: aVect_importRattr ! wrapper to mct_aVect_importRattr which doesn't require a pointer input + public :: aVect_exportRattr ! wrapper to mct_aVect_exportRattr which doesn't require pointer management for the output + +contains + + !----------------------------------------------------------------------- + subroutine create_aVect_with_data_rows_are_points(av, attr_tags, data) + ! + ! !DESCRIPTION: + ! Creates an attribute vector with a given set of fields, which are all assumed to be + ! real-valued. Then fills it with the given data. + ! + ! The data should be given as a 2-d array, [point, field]. So the second dimension + ! should be the same size as the attr_tags array, with data(:,i) being used to fill + ! the attr_tags(i) variable. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(inout) :: av + character(len=*), intent(in) :: attr_tags(:) + real(r8), intent(in) :: data(:,:) + ! + ! !LOCAL VARIABLES: + integer :: nfields + integer :: npoints + integer :: field_index + + character(len=*), parameter :: subname = 'create_aVect_with_data_rows_are_points' + !----------------------------------------------------------------------- + + npoints = size(data, 1) + nfields = size(data, 2) + + if (size(attr_tags) /= nfields) then + print *, subname, ' ERROR: dimensionality mismatch between attr_tags and data' + stop + end if + + call create_aVect_without_data(av, attr_tags, npoints) + + do field_index = 1, nfields + call aVect_importRattr(av, trim(attr_tags(field_index)), data(:,field_index)) + end do + + end subroutine create_aVect_with_data_rows_are_points + + !----------------------------------------------------------------------- + subroutine create_aVect_with_data_rows_are_fields(av, attr_tags, data) + ! + ! !DESCRIPTION: + ! Creates an attribute vector with a given set of fields, which are all assumed to be + ! real-valued. Then fills it with the given data. + ! + ! The data should be given as a 2-d array, [field, point]. So the first dimension + ! should be the same size as the attr_tags array, with data(i,:) being used to fill + ! the attr_tags(i) variable. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(inout) :: av + character(len=*), intent(in) :: attr_tags(:) + real(r8), intent(in) :: data(:,:) + !----------------------------------------------------------------------- + + call create_aVect_with_data_rows_are_points(av, attr_tags, transpose(data)) + + end subroutine create_aVect_with_data_rows_are_fields + + !----------------------------------------------------------------------- + subroutine create_aVect_without_data(av, attr_tags, lsize) + ! + ! !DESCRIPTION: + ! Creates an attribute vector with a given set of fields, with space for the given + ! number of points in each field. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(inout) :: av + character(len=*), intent(in) :: attr_tags(:) + integer, intent(in) :: lsize + ! + ! !LOCAL VARIABLES: + integer :: nfields + integer :: field_index + integer :: list_length + character(len=:), allocatable :: attr_list + + character(len=*), parameter :: subname = 'create_aVect_without_data' + !----------------------------------------------------------------------- + + nfields = size(attr_tags) + list_length = nfields * (len(attr_tags) + 1) + allocate(character(len=list_length) :: attr_list) + + attr_list = trim(attr_tags(1)) + do field_index = 2, nfields + attr_list = trim(attr_list) // ":" // trim(attr_tags(field_index)) + end do + + call mct_aVect_init(av, rList = attr_list, lsize = lsize) + + end subroutine create_aVect_without_data + + !----------------------------------------------------------------------- + subroutine aVect_importRattr(av, attr_tag, data) + ! + ! !DESCRIPTION: + ! This routine is similar to mct_aVect_importRattr, but it doesn't require a pointer + ! input - so it is often more convenient than calling mct_aVect_importRattr directly. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_aVect), intent(inout) :: av + character(len=*), intent(in) :: attr_tag + real(r8), intent(in) :: data(:) + ! + ! !LOCAL VARIABLES: + real(r8), pointer :: data_ptr(:) + + character(len=*), parameter :: subname = 'aVect_importRattr' + !----------------------------------------------------------------------- + + allocate(data_ptr(size(data))) + data_ptr(:) = data(:) + call mct_aVect_importRattr(av, trim(attr_tag), data_ptr) + deallocate(data_ptr) + + end subroutine aVect_importRattr + + !----------------------------------------------------------------------- + function aVect_exportRattr(av, attr_tag) result(data) + ! + ! !DESCRIPTION: + ! This function is similar to mct_aVect_exportRattr, but (1) it is a function rather + ! than a subroutine (so that it can be included inline in other statements), and (2) + ! it handles the pointer management for you, so that the caller doesn't have to. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), allocatable :: data(:) ! function result + type(mct_aVect), intent(in) :: av + character(len=*), intent(in) :: attr_tag + ! + ! !LOCAL VARIABLES: + real(r8), pointer :: data_ptr(:) + + character(len=*), parameter :: subname = 'aVect_exportRattr' + !----------------------------------------------------------------------- + + nullify(data_ptr) + call mct_aVect_exportRattr(av, trim(attr_tag), data_ptr) + data = data_ptr + deallocate(data_ptr) + end function aVect_exportRattr + + +end module avect_wrapper_mod diff --git a/driver-mct/unit_test/utils/create_mapper_mod.F90 b/driver-mct/unit_test/utils/create_mapper_mod.F90 new file mode 100644 index 000000000000..7afc11692ecd --- /dev/null +++ b/driver-mct/unit_test/utils/create_mapper_mod.F90 @@ -0,0 +1,176 @@ +module create_mapper_mod + ! This module supports building mappers for use in unit tests + + use mct_mod + use mct_wrapper_mod, only : mct_communicator, mct_compid + use shr_kind_mod, only : r8 => shr_kind_r8 + use seq_map_type_mod, only : seq_map + use simple_map_mod, only : simple_map_type + + implicit none + private + save + + public :: create_mapper ! create a simple mapper + public :: clean_mapper ! deallocate memory associated with a mapper + public :: create_gsmap ! used in test_check_fields + +contains + + !----------------------------------------------------------------------- + subroutine create_mapper(mapper, simple_map) + ! + ! !DESCRIPTION: + ! Create a simple mapper + ! + ! !USES: + ! + ! !ARGUMENTS: + type(seq_map), intent(out) :: mapper + class(simple_map_type), intent(in) :: simple_map + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'create_mapper' + !----------------------------------------------------------------------- + + mapper%copy_only = .false. + mapper%rearrange_only = .false. + mapper%esmf_map = .false. + mapper%mapfile = ' ' + + ! The strategy just relates to whether the mapping is done on the source or + ! destination decomposition, which is irrelevant for a single-processor unit test + mapper%strategy = 'X' + + ! May need to make this more sophisticated if it causes problems to use 0 for all + ! mappers + mapper%counter = 0 + + allocate(mapper%gsmap_s) + call create_gsmap(mapper%gsmap_s, simple_map%get_n_source_points()) + allocate(mapper%gsmap_d) + call create_gsmap(mapper%gsmap_d, simple_map%get_n_dest_points()) + + call mct_rearr_init(mapper%gsmap_s, mapper%gsmap_d, mct_communicator, mapper%rearr) + + call create_sMatp(mapper%sMatp, simple_map, mapper%gsmap_s, mapper%gsmap_d) + + end subroutine create_mapper + + + !----------------------------------------------------------------------- + subroutine clean_mapper(mapper) + ! + ! !DESCRIPTION: + ! Deallocate memory associated with a mapper. + ! + ! This currently only deallocates the memory used in all mappers, NOT the + ! cart3d-specific memory. + ! + ! This assumes that gsmaps were created specially for this mapper, as is done in the + ! convenience functions in this module (as opposed to having the mapper's gsmap + ! pointers simply pointing to existing gsmaps). + ! + ! !USES: + ! + ! !ARGUMENTS: + type(seq_map), intent(inout) :: mapper + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'clean_mapper' + !----------------------------------------------------------------------- + + call mct_rearr_clean(mapper%rearr) + call mct_sMatP_clean(mapper%sMatp) + + call mct_gsMap_clean(mapper%gsmap_s) + deallocate(mapper%gsmap_s) + call mct_gsMap_clean(mapper%gsmap_d) + deallocate(mapper%gsmap_d) + + end subroutine clean_mapper + + !----------------------------------------------------------------------- + subroutine create_gsmap(gsmap, npts) + ! + ! !DESCRIPTION: + ! Creates a simple, single-processor gsmap + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_gsMap), intent(out) :: gsmap + integer, intent(in) :: npts + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'create_gsmap' + !----------------------------------------------------------------------- + + call mct_gsMap_init(GSMap = gsmap, & + comp_id = mct_compid, & + ngseg = 1, & + gsize = npts, & + start = [1], & + length = [npts], & + pe_loc = [0]) + + end subroutine create_gsmap + + !----------------------------------------------------------------------- + subroutine create_sMatp(sMatp, simple_map, gsmap_s, gsmap_d) + ! + ! !DESCRIPTION: + ! Creates an sMatp object + ! + ! !USES: + ! + ! !ARGUMENTS: + type(mct_sMatp), intent(out) :: sMatp + class(simple_map_type), intent(in) :: simple_map + type(mct_gsMap), intent(in) :: gsmap_s + type(mct_gsMap), intent(in) :: gsmap_d + ! + ! !LOCAL VARIABLES: + integer :: n_elements ! number of elements in the sparse matrix + type(mct_sMat) :: sMati ! non-parallel sparse matrix + + ! The following pointers are needed because the MCT routines want pointer inputs + integer, pointer :: source_indices(:) + integer, pointer :: dest_indices(:) + real(r8), pointer :: matrix_elements(:) + + character(len=*), parameter :: subname = 'create_sMatp' + !----------------------------------------------------------------------- + + n_elements = simple_map%get_n_overlaps() + + call mct_sMat_init(sMati, & + nrows = simple_map%get_n_dest_points(), & + ncols = simple_map%get_n_source_points(), & + lsize = n_elements) + + allocate(source_indices(n_elements)) + source_indices = simple_map%get_source_indices() + call mct_sMat_ImpGColI(sMati, source_indices, n_elements) + deallocate(source_indices) + + allocate(dest_indices(n_elements)) + dest_indices = simple_map%get_dest_indices() + call mct_sMat_ImpGRowI(sMati, dest_indices, n_elements) + deallocate(dest_indices) + + allocate(matrix_elements(n_elements)) + matrix_elements = simple_map%get_overlap_weights() + call mct_sMat_ImpMatrix(sMati, matrix_elements, n_elements) + deallocate(matrix_elements) + + call mct_sMatP_Init(sMatP, sMati, gsmap_s, gsmap_d, 0, mct_communicator, gsmap_s%comp_id) + + call mct_sMat_Clean(sMati) + end subroutine create_sMatp + + +end module create_mapper_mod diff --git a/driver-mct/unit_test/utils/mct_wrapper_mod.F90 b/driver-mct/unit_test/utils/mct_wrapper_mod.F90 new file mode 100644 index 000000000000..c93d4924f757 --- /dev/null +++ b/driver-mct/unit_test/utils/mct_wrapper_mod.F90 @@ -0,0 +1,66 @@ +module mct_wrapper_mod + ! This module provides some variables and convenience functions for the sake of unit + ! tests that use mct. + ! + ! Any test that uses mct should call mct_init in its initialization, and mct_clean in + ! its teardown. + + implicit none + private + +#include + + public :: mct_init ! initialize data structures needed to use mct + public :: mct_clean ! clean up mct data structures that were set up by mct_init + + ! MPI communicator that can be used wherever mct routines expect a communicator + integer, parameter, public :: mct_communicator = MPI_COMM_WORLD + + ! value that can be used wherever mct routines expect a component ID + integer, parameter, public :: mct_compid = 1 + +contains + + !----------------------------------------------------------------------- + subroutine mct_init() + ! + ! !DESCRIPTION: + ! Initializes data structures needed to use mct. + ! + ! Expects that mpi_init has already been called. + ! + ! !USES: + use seq_comm_mct, only : seq_comm_init + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'mct_init' + !----------------------------------------------------------------------- + + call seq_comm_init(mct_communicator, mct_communicator, nmlfile = ' ') + end subroutine mct_init + + !----------------------------------------------------------------------- + subroutine mct_clean() + ! + ! !DESCRIPTION: + ! Cleans up mct data structures that were set up by mct_init. + ! + ! !USES: + use seq_comm_mct, only : seq_comm_clean + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'mct_clean' + !----------------------------------------------------------------------- + + call seq_comm_clean() + + end subroutine mct_clean + + +end module mct_wrapper_mod diff --git a/driver-mct/unit_test/utils/simple_map_mod.F90 b/driver-mct/unit_test/utils/simple_map_mod.F90 new file mode 100644 index 000000000000..485dca444816 --- /dev/null +++ b/driver-mct/unit_test/utils/simple_map_mod.F90 @@ -0,0 +1,326 @@ +module simple_map_mod + + ! This module defines a class for holding data describing a mapping between two grids + +#include "shr_assert.h" + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_log_mod, only : errMsg => shr_log_errMsg + + implicit none + private + + + type, public :: simple_map_type + private + integer :: n_overlaps ! number of overlaps between the source & destination grid (size of sparse matrix) + integer, allocatable :: source_indices(:) + integer, allocatable :: dest_indices(:) + real(r8), allocatable :: overlap_weights(:) + contains + procedure, public :: get_n_overlaps ! get number of overlaps (size of sparse matrix) + procedure, public :: get_n_source_points ! get number of source points + procedure, public :: get_n_dest_points ! get number of destination points + procedure, public :: get_source_indices ! get source indices in the sparse matrix + procedure, public :: get_dest_indices ! get dest indices in the sparse matrix + procedure, public :: get_overlap_weights ! get overlap weights (the values in the sparse matrix) + + procedure, private :: check_okay ! check if the data in this object are valid + procedure, private :: check_for_duplicate_overlaps + procedure, private :: check_for_nonpositive_weights + end type simple_map_type + + interface simple_map_type + module procedure constructor + end interface simple_map_type + + ! Note: This could be written as a constructor, but instead is made a module-level + ! routine so that it can be called with a more meaningful name. + public :: create_simple_map_with_one_source ! create a simple_map_type instance with a single source cell + +contains + + ! ======================================================================== + ! Constructors and creation methods + ! ======================================================================== + + !----------------------------------------------------------------------- + function constructor(source_indices, dest_indices, overlap_weights) result(this) + ! + ! !DESCRIPTION: + ! Create a simple_map_type instance. + ! + ! The sizes of source_indices, dest_indices and overlap_weights must all be the same. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(simple_map_type) :: this ! function result + integer, intent(in) :: source_indices(:) + integer, intent(in) :: dest_indices(:) + real(r8), intent(in) :: overlap_weights(:) + ! + ! !LOCAL VARIABLES: + integer :: n_overlaps + + character(len=*), parameter :: subname = 'constructor' + !----------------------------------------------------------------------- + + n_overlaps = size(overlap_weights) + call shr_assert(size(source_indices) == n_overlaps, file=__FILE__, line=__LINE__) + call shr_assert(size(dest_indices) == n_overlaps, file=__FILE__, line=__LINE__) + + this%n_overlaps = n_overlaps + this%source_indices = source_indices + this%dest_indices = dest_indices + this%overlap_weights = overlap_weights + + ! Perform some error-checking + call this%check_okay() + end function constructor + + !----------------------------------------------------------------------- + function create_simple_map_with_one_source(ndest) result(simple_map) + ! + ! !DESCRIPTION: + ! Create a simple_map_type instance with a single source cell. + ! + ! Assumes that all destination cells are fully contained within this single source cell. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(simple_map_type) :: simple_map ! function return value + integer, intent(in) :: ndest ! number of destination cells + ! + ! !LOCAL VARIABLES: + integer :: dest_index + integer :: source_indices(ndest) + integer :: dest_indices(ndest) + real(r8) :: overlap_weights(ndest) + + character(len=*), parameter :: subname = 'create_simple_map_with_one_source' + !----------------------------------------------------------------------- + + source_indices(:) = 1 + dest_indices = [(dest_index, dest_index = 1, ndest)] + overlap_weights(:) = 1._r8 + simple_map = simple_map_type(source_indices=source_indices, dest_indices=dest_indices,& + overlap_weights=overlap_weights) + + end function create_simple_map_with_one_source + + + ! ======================================================================== + ! Class methods + ! ======================================================================== + + !----------------------------------------------------------------------- + function get_n_overlaps(this) result(n_overlaps) + ! + ! !DESCRIPTION: + ! Get number of overlaps (size of sparse matrix) + ! + ! !USES: + ! + ! !ARGUMENTS: + integer :: n_overlaps ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_n_overlaps' + !----------------------------------------------------------------------- + + n_overlaps = this%n_overlaps + end function get_n_overlaps + + !----------------------------------------------------------------------- + function get_n_source_points(this) result(n_source_points) + ! + ! !DESCRIPTION: + ! Get number of source points + ! + ! !USES: + ! + ! !ARGUMENTS: + integer :: n_source_points ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_n_source_points' + !----------------------------------------------------------------------- + + n_source_points = maxval(this%source_indices) + end function get_n_source_points + + !----------------------------------------------------------------------- + function get_n_dest_points(this) result(n_dest_points) + ! + ! !DESCRIPTION: + ! Get number of destination points + ! + ! !USES: + ! + ! !ARGUMENTS: + integer :: n_dest_points ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_n_dest_points' + !----------------------------------------------------------------------- + + n_dest_points = maxval(this%dest_indices) + end function get_n_dest_points + + !----------------------------------------------------------------------- + function get_source_indices(this) result(source_indices) + ! + ! !DESCRIPTION: + ! Get source indices in the sparse matrix + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, allocatable, dimension(:) :: source_indices ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_source_indices' + !----------------------------------------------------------------------- + + source_indices = this%source_indices + end function get_source_indices + + !----------------------------------------------------------------------- + function get_dest_indices(this) result(dest_indices) + ! + ! !DESCRIPTION: + ! Get dest indices in the sparse matrix + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, allocatable, dimension(:) :: dest_indices ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_dest_indices' + !----------------------------------------------------------------------- + + dest_indices = this%dest_indices + end function get_dest_indices + + !----------------------------------------------------------------------- + function get_overlap_weights(this) result(overlap_weights) + ! + ! !DESCRIPTION: + ! Get overlap weights (the values in the sparse matrix) + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), allocatable, dimension(:) :: overlap_weights ! function result + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_overlap_weights' + !----------------------------------------------------------------------- + + overlap_weights = this%overlap_weights + end function get_overlap_weights + + !----------------------------------------------------------------------- + subroutine check_okay(this) + ! + ! !DESCRIPTION: + ! Makes sure that the data in this object are valid + ! + ! !USES: + ! + ! !ARGUMENTS: + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'check_okay' + !----------------------------------------------------------------------- + + call this%check_for_duplicate_overlaps() + call this%check_for_nonpositive_weights() + end subroutine check_okay + + + + !----------------------------------------------------------------------- + subroutine check_for_duplicate_overlaps(this) + ! + ! !DESCRIPTION: + ! Confirms that there are not multiple overlaps with the same source and destination + ! indices. + ! + ! Aborts if any duplicates are found. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + logical, allocatable :: overlap_found(:,:) + integer :: overlap_index + integer :: source_index + integer :: dest_index + + character(len=*), parameter :: subname = 'check_for_duplicate_overlaps' + !----------------------------------------------------------------------- + + allocate(overlap_found(this%get_n_source_points(), this%get_n_dest_points()), source=.false.) + + do overlap_index = 1, this%get_n_overlaps() + source_index = this%source_indices(overlap_index) + dest_index = this%dest_indices(overlap_index) + if (overlap_found(source_index, dest_index)) then + print *, subname, ' ERROR: duplicate found at: ', overlap_index, source_index, & + dest_index + stop + end if + overlap_found(source_index, dest_index) = .true. + end do + + end subroutine check_for_duplicate_overlaps + + !----------------------------------------------------------------------- + subroutine check_for_nonpositive_weights(this) + ! + ! !DESCRIPTION: + ! Confirms that all weights are positive. + ! + ! Aborts if any zero or negative weights are found. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(simple_map_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + integer :: overlap_index + + character(len=*), parameter :: subname = 'check_for_nonpositive_weights' + !----------------------------------------------------------------------- + + do overlap_index = 1, this%get_n_overlaps() + if (this%overlap_weights(overlap_index) <= 0) then + print *, subname, ' ERROR: non-positive weight found at: ', overlap_index, & + this%overlap_weights(overlap_index) + stop + end if + end do + end subroutine check_for_nonpositive_weights + + +end module simple_map_mod