From 8c066f0205ee3d1a14aa3b809318bbc7ce461aca Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Fri, 29 Jul 2022 20:38:34 -0600 Subject: [PATCH 01/79] Work on adding history Implement read of new history namelist Added unit tests for CAM history unit tests Added multiplier parser and utiliity unit tests Remove redundant filenames.F90 Finish some checking functions Added error strings to command parser functions First pass of HistoryConfig class Start on testing history configuration parsing Progress on hist config parsing Still working on new format, start with get_entry Finish parse_hist_config_file First pass at some AMWG history configuration Updated from focus meeting Fix location of history unit test sample files Take out debug exception Test passes but output file is not yet correct. Full test of flat user_nl_cam passes Updated namelist names to begin with hist_ Rename user_nl_cam history entries to begin with hist_ Progress on multi-level history config Reconfigured class structure, flat and multi tests pass Added history configuration parsing and writing to buildnml Add diagnostic element to registry Updated CMakeLists.txt for new share code file layout --- cime_config/buildnml | 40 +- cime_config/hist_config.py | 1000 ++ src/control/cam_initfiles.F90 | 2 +- src/control/cam_instance.F90 | 48 +- src/control/filenames.F90 | 210 - src/cpl/mct/atm_comp_mct.F90 | 2 +- src/data/registry.xml | 6 + src/data/registry_v1_0.xsd | 20 + src/history/cam_hist_config_file.F90 | 703 ++ src/history/cam_history.F90 | 5131 ++++++++++ src/history/cam_history_support.F90 | 2019 ++++ src/utils/cam_filenames.F90 | 217 + src/utils/cam_pio_utils.F90 | 109 +- src/utils/cam_time_coord.F90 | 2 +- src/utils/string_utils.F90 | 129 +- src/utils/time_manager.F90 | 2 +- test/hist_tests/CMakeLists.txt | 140 + test/hist_tests/cam_history_support.F90 | 9 + test/hist_tests/cam_interp_mod.F90 | 60 + test/hist_tests/sample_files/amwg_hist_config | 17 + test/hist_tests/sample_files/rrtmg_rad_config | 46 + .../sample_files/single_good_config.nl | 16 + .../sample_files/two_good_configs.nl | 26 + test/hist_tests/sample_files/user_nl_cam | 17 + .../hist_tests/sample_files/user_nl_cam_rrtmg | 15 + test/hist_tests/test_history.F90 | 175 + test/include/cam_abortutils.F90 | 76 +- test/include/cam_control_mod.F90 | 50 + test/include/dtypes.h | 6 + test/include/shr_assert_mod.F90 | 8602 +++++++++++++++++ test/include/shr_infnan_mod.F90 | 110 +- test/include/shr_kind_mod.F90 | 19 - test/include/shr_string_mod.F90 | 2037 ++++ test/include/spmd_utils.F90 | 5 +- test/include/time_manager.F90 | 312 + .../hist_config_files/amwg_hist_config | 17 + .../hist_config_files/atm_in_flat | 29 + .../hist_config_files/atm_in_multi | 68 + .../sample_files/hist_config_files/rad_config | 47 + .../hist_config_files/user_nl_cam_flat | 18 + .../hist_config_files/user_nl_cam_multi | 17 + test/unit/test_hist_config.py | 171 + test/utils_tests/CMakeLists.txt | 127 + test/utils_tests/string_utils_tests.F90 | 88 + test/utils_tests/test_utils.F90 | 30 + 45 files changed, 21599 insertions(+), 391 deletions(-) create mode 100644 cime_config/hist_config.py delete mode 100644 src/control/filenames.F90 create mode 100644 src/history/cam_hist_config_file.F90 create mode 100644 src/history/cam_history.F90 create mode 100644 src/history/cam_history_support.F90 create mode 100644 src/utils/cam_filenames.F90 create mode 100644 test/hist_tests/CMakeLists.txt create mode 100644 test/hist_tests/cam_history_support.F90 create mode 100644 test/hist_tests/cam_interp_mod.F90 create mode 100644 test/hist_tests/sample_files/amwg_hist_config create mode 100644 test/hist_tests/sample_files/rrtmg_rad_config create mode 100644 test/hist_tests/sample_files/single_good_config.nl create mode 100644 test/hist_tests/sample_files/two_good_configs.nl create mode 100644 test/hist_tests/sample_files/user_nl_cam create mode 100644 test/hist_tests/sample_files/user_nl_cam_rrtmg create mode 100644 test/hist_tests/test_history.F90 create mode 100644 test/include/cam_control_mod.F90 create mode 100644 test/include/dtypes.h create mode 100644 test/include/shr_assert_mod.F90 delete mode 100644 test/include/shr_kind_mod.F90 create mode 100644 test/include/shr_string_mod.F90 create mode 100644 test/include/time_manager.F90 create mode 100644 test/unit/sample_files/hist_config_files/amwg_hist_config create mode 100644 test/unit/sample_files/hist_config_files/atm_in_flat create mode 100644 test/unit/sample_files/hist_config_files/atm_in_multi create mode 100644 test/unit/sample_files/hist_config_files/rad_config create mode 100644 test/unit/sample_files/hist_config_files/user_nl_cam_flat create mode 100644 test/unit/sample_files/hist_config_files/user_nl_cam_multi create mode 100644 test/unit/test_hist_config.py create mode 100644 test/utils_tests/CMakeLists.txt create mode 100644 test/utils_tests/string_utils_tests.F90 create mode 100644 test/utils_tests/test_utils.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 370d9879..35b16b11 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -5,6 +5,7 @@ CAM namelist creator """ import sys import os +import re import shutil import logging import glob @@ -31,6 +32,8 @@ sys.path.append(_CIME_CONFIG_PATH) # Import CAM's configure structure: from cam_config import ConfigCAM +# HistoryConfig allows translation from user_nl_cam into Fortran namelists +from hist_config import HistoryConfig #Import CAM's ParamGen class: from atm_in_paramgen import AtmInParamGen @@ -38,6 +41,9 @@ from atm_in_paramgen import AtmInParamGen # Open CIME case log: _LOGGER = logging.getLogger(__name__) +# Beginning of valid user_nl configuration line +_USER_NL_LINE = re.compile(r"^[a-z][a-z0-9_]*[ ]*=", re.IGNORECASE) + ################# #HELPER FUNCTIONS ################# @@ -51,6 +57,7 @@ class CamBuildnmlError(ValueError): # This simplifies the filename mangling for different cases. def _create_ic_filename(inst_string, i_or_r, run_refcase, run_refdate, run_reftod): + """Simplify the filename mangling for different cases.""" return f"{run_refcase}.cam{inst_string}.{i_or_r}.{run_refdate}-{run_reftod}.nc" ################## @@ -297,7 +304,28 @@ def buildnml(case, caseroot, compname): # End if # Determine location and name of "user_nl_cam" files: - user_nl_file = os.path.join(caseroot, "user_nl_cam" + inst_string) + user_nl_fname = "user_nl_cam" + inst_string + user_nl_file = os.path.join(caseroot, user_nl_fname) + + # Temporary user_nl file with history config stripped + user_nl_temp = os.path.join(confdir, "user_nl_temp") + if os.path.exists(user_nl_temp): + os.remove(user_nl_temp) + # end if + + # Remove history configuration from the normal user_nl content + with open(user_nl_file, 'r') as infile: + clines = infile.readlines() + # end with + with open(user_nl_temp, 'w') as outfile: + for line in clines: + sline = line.strip() + if ((not sline) or (sline[0] == '!') or + (_USER_NL_LINE.match(sline) is not None)): + outfile.write(line) + # end if + # end or + # end with # Check that file actually exists. If not then throw an error: if not os.path.exists(user_nl_file): @@ -362,6 +390,16 @@ def buildnml(case, caseroot, compname): # Create CAM namelist using CIME's nmlgen routine: pg_atm.write(namelist_file) + # Add history namelists to atm_in + hist_configs = HistoryConfig(filename=user_nl_file, logger=_LOGGER) + with open(namelist_file, 'a', encoding='utf-8') as nl_file: + hist_configs.output_class_namelist(nl_file) + for key in sorted(hist_configs.keys()): + hist_configs[key].output_config_namelist(nl_file) + # end for + # end with + + ############################################################################### def _main_func(): diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py new file mode 100644 index 00000000..70c89258 --- /dev/null +++ b/cime_config/hist_config.py @@ -0,0 +1,1000 @@ +""" +Routines to parse history configuration and produce namelist output +suitable for atm_in. +Input can be history configuration files or history entries in user_nl_cam. +""" + +# Python library imports +from collections import OrderedDict +import logging +import os +import re +import sys + +# Find and include the ccpp-framework scripts directory +# Assume we are in /src/data and SPIN is in /ccpp_framework +__CURRDIR = os.path.abspath(os.path.dirname(__file__)) +__CAMROOT = os.path.abspath(os.path.join(__CURRDIR, os.pardir)) +__SPINSCRIPTS = os.path.join(__CAMROOT, "ccpp_framework", 'scripts') +if __SPINSCRIPTS not in sys.path: + sys.path.append(__SPINSCRIPTS) +# end if + +# CCPP framework imports +# pylint: disable=wrong-import-position +from parse_tools import ParseObject, context_string, ParseInternalError +# pylint: enable=wrong-import-position + +############################################################################## +### +### Support functions for history configuration commands +### +############################################################################## + +############################################################################## +def blank_config_line(line): +############################################################################## + """Return True if is a valid history config blank or comment + line. Also return True if we have reached the end of the file + (no line)""" + return (not line) or (line.strip()[0] == '!') + +############################################################################## +def _is_integer(entry): +############################################################################## + """Return the integer value of the string, , if it represents a + valid integer. Otherwise, return None + Also, return an error string or None if no error is found. + >>> _is_integer("314159") + (314159, None) + >>> _is_integer("3.14159") + (None, '3.14159 is not an integer') + """ + errmsg = None + if isinstance(entry, int): + ival = entry + else: + try: + ival = int(str(entry).strip()) + except ValueError: + ival = None + errmsg = "{} is not an integer".format(entry.strip()) + # end try + # end if + return ival, errmsg + +############################################################################## +def _list_of_idents(entry, sep=','): +############################################################################## + """Return a list of identifiers if is a valid list of identifiers. + Otherwise, return None. + A valid identifier is something that can be a NetCDF variable + The identifiers must be separated by . + Whitespace is not significant (but not allowed as part of an identifier). + Also, return an error string or None if no error is found. + >>> _list_of_idents("foo") + (['foo'], None) + >>> _list_of_idents("foo bar") + (None, "'foo bar' is not a valid identifier") + >>> _list_of_idents("foo, bAr") + (['foo', 'bAr'], None) + >>> _list_of_idents("foo, BA2r3") + (['foo', 'BA2r3'], None) + >>> _list_of_idents("foo, 3bar") + (None, "'3bar' is not a valid identifier") + >>> _list_of_idents("foo.3bar") + (None, "'foo.3bar' is not a valid identifier") + >>> _list_of_idents("foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd") + (None, "'foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd' is not a valid identifier") + >>> _list_of_idents("") + (None, 'No identifiers found') + """ + errmsg = None + if entry: + good_list = [x.strip() for x in str(entry).split(sep)] + for sample in good_list: + if _NETCDF_ID_RE.match(sample) is None: + if errmsg: + errmsg += "\n " + else: + errmsg = "" + # end if + errmsg += "'{}' is not a valid identifier".format(sample) + # end if + # end for + if errmsg: + good_list = None + # end if + else: + good_list = None + errmsg = "No identifiers found" + # end if + return good_list, errmsg + +############################################################################## +def _is_mult_period(entry): +############################################################################## + """Return a tuple (, ), if is a valid time period + entry. Otherwise, return None. + A time-period entry is of the form: + [ *] + where is an optional integer and is one of the recognized + time period (e.g., steps, days, months). + Also, return an error string or None if no error is found. + >>> _is_mult_period("nsteps") + ((1, 'nsteps'), None) + >>> _is_mult_period("3 * nmonths") + ((3, 'nmonths'), None) + >>> _is_mult_period("2*fortnights") + (None, 'period must be one of nsteps, nstep, nseconds, nsecond, nminutes, nminute, nhours, nhour, ndays, nday, monthly, nmonths, nmonth, nyears, nyear, steps, seconds, minutes, hours, days, months, years') + >>> _is_mult_period("") + (None, 'no entry for frequency') + >>> _is_mult_period("1*nyear") + ((1, 'nyear'), None) + >>> _is_mult_period("-6*nhours") + (None, 'multiplier must be a positive integer') + """ + if entry: + tokens = [x.strip() for x in str(entry).split('*')] + errmsg = None + else: + tokens = list() + errmsg = "a frequency ([*]period) is required" + # end if + num_tokens = len(tokens) + if num_tokens == 1: + good_entry = 1 + elif num_tokens == 2: + good_entry, errmsg = _is_integer(tokens[0]) + if errmsg or (good_entry <= 0): + good_entry = None + errmsg = "multiplier must be a positive integer" + # end if + else: + good_entry = None + errmsg = "no entry for frequency" + # end if + if good_entry: + period = tokens[-1].lower() + if period in HistConfigEntry._TIME_PERIODS: + good_entry = (good_entry, period) + else: + good_entry = None + time_periods = ", ".join(HistConfigEntry._TIME_PERIODS) + errmsg = "period must be one of {}".format(time_periods) + # end if + # end if + return good_entry, errmsg + +############################################################################## +def _is_prec_str(entry): +############################################################################## + """Return the output-precision represented by or None if it + is invalid. + Also, return an error string or None if no error is found. + >>> _is_prec_str(' REAL32') + ('REAL32', None) + >>> _is_prec_str('REAL64 ') + ('REAL64', None) + >>> _is_prec_str('real32') + ('REAL32', None) + >>> _is_prec_str('real64') + ('REAL64', None) + >>> _is_prec_str('double') + (None, 'precision must be one of REAL32, REAL64') + """ + ustr = entry.strip().upper() + errmsg = None + if ustr not in HistConfigEntry._OUT_PRECS: + ustr = None + out_precs = ", ".join(HistConfigEntry._OUT_PRECS) + errmsg = "precision must be one of {}".format(out_precs) + # end if + return ustr, errmsg + +############################################################################## +def _is_filename(entry): +############################################################################## + """Return if it represents a valid history configuration + filename or None if it is invalid. + Note, not currently checking this string (just that it is a string). + Also, return an error string or None if no error is found. + """ + if isinstance(entry, str): + fval = entry.strip() + else: + fval = None + # end if + return fval, None + +############################################################################## +class HistFieldList(): +############################################################################## + """Class to store information about a history configuration field list. + """ + + __add_field_msg = "Added {} field, '{}' to hist volume, {}{}" + __dup_field_msg = "Field, '{}' already in {} fields for hist volume, {}{}" + __del_field_msg = "Removed field, '{}' from {} fields on hist volume, {}{}" + __missing_msg = "Cannot remove field, '{}', not found on hist volume, {}{}" + __max_linelen = 120 # for namelist output + + def __init__(self, volume, list_type, list_desc): + """Initialize a named HistFieldList with an empty list. + is the history volume for this field list. + is the type of field list (e.g., 'inst', 'avg'). + is a field type description for log messages""" + self.__volume = volume + self.__type = list_type + self.__desc = list_desc + self.__field_names = list() + self.__max_namelen = 0 + + def _add_item(self, item, comp_lists, pobj, logger): + """Add field name, to this object and return True if this + field name was added. + HistFieldList objects in are searched and is *not* + added if it is found in any of those objects. + is a single item to be added. + is the ParseObject source of . + """ + iadd = str(item).strip() + do_add = True + for hflist in comp_lists: + if iadd in hflist.__field_names: + do_add = False + ctx = context_string(pobj) + logger.warning(hflist.__dup_field_msg.format(iadd, hflist.desc, + self.volume, ctx)) + break + # end if + # end for + if do_add: + self.__field_names.append(iadd) + self.__max_namelen = max(len(iadd), self.__max_namelen) + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(self.__add_field_msg.format(self.desc, iadd, + self.volume, ctx)) + # end if + # end if (no else, already warned above) + return do_add + + def add_fields(self, items, comp_lists, pobj, logger): + """Add to this object and return True if all items were added. + can be a single item or a list. + HistFieldList objects in are searched and is *not* + added if it is found in any of those objects. + is the ParseObject source of + """ + context = context_string(pobj) + if isinstance(items, list): + do_add = True + for item in items: + do_add &= self._add_item(item, comp_lists, pobj, logger) + # end for + else: + do_add = self._add_item(items, comp_lists, pobj, logger) + # end if + return do_add + + def remove_fields(self, fields, pobj, logger): + """Remove all field names in from this HistFieldList object. + Return a set of the removed fields. + """ + removed_fields = set() + for field_name in fields: + if field_name in self.__field_names: + self.__field_names.remove(field_name) + removed_fields.add(field_name) + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(self.__del_field_msg.format(field_name, + self.desc, + self.volume, ctx)) + # end if + # end if + # end for + return removed_fields + + def num_fields(self): + """Return the number of fields in this HistFieldList object.""" + return len(self.__field_names) + + + def output_nl_fieldlist(self, outfile, field_varname): + """Output the field name of this HistFieldList object as a namelist + variable that is an array of strings. + : the name of the namelist variable + : File to write + A list is only output if there are members in the list + """ + if self.__field_names: + lhs = " {} = ".format(field_varname) + blank_lhs = ' '*(len(field_varname) + 5) + # Break up output into lines + num_fields = self.num_fields() + fld_end = -1 + while fld_end < num_fields - 1: + fld_beg = fld_end + 1 + # Always output at least one field + fld_end = fld_beg + line_len = len(lhs) + self.max_len + 2 + while line_len < self.__max_linelen: + if fld_end + 1 >= num_fields: + break + # end if + next_len = self.max_len + 4 + if (line_len + next_len) > self.__max_linelen: + break + # end if + line_len += next_len + fld_end = fld_end + 1 + # end while + # Output this line + comma = "," if fld_end < num_fields - 1 else "" + quotelist = ["'{}{}'".format(x, ' '*(self.max_len - len(x))) + for x in self.__field_names[fld_beg:fld_end+1]] + outfile.write("{}{}{}\n".format(lhs, ", ".join(quotelist), + comma)) + lhs = blank_lhs + # end while + # end if + + @property + def volume(self): + """Return the volume for this HistFieldList""" + return self.__volume + + @property + def type(self): + """Return the field type for this HistFieldList""" + return self.__type + + @property + def desc(self): + """Return the field type description for this HistFieldList""" + return self.__desc + + @property + def max_len(self): + """Return the length of the longest field in this HistFieldList object. + """ + return self.__max_namelen + + def __str__(self): + """Return a string representing this HistFieldList object and its + contents. + """ + return "{}: [{}]".format(self.name, ", ".join(self.__field_names)) + +############################################################################## +### +### History configuration types (for parsing history configuration entries +### +############################################################################## + +_NETCDF_ID_RE = re.compile(r"^[a-z][a-z0-9_]{0,62}$", re.IGNORECASE) + +############################################################################## +class HistoryConfigError(ValueError): +############################################################################## + """Error type specific to history configuration parsing""" + + def __init__(self, message): + """Initialize this exception""" + logging.shutdown() + super(HistoryConfigError, self).__init__(message) + +############################################################################## +class HistConfigEntry(): +############################################################################## + """Object to hold information, checking, and conversion functions for + a history configuration entry type + """ + + __HIST_CONF_ENTRY_RE = re.compile(r"[a-z][a-z_]*") + __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:=][ ]*(.*)$" + + # Note, these lists should match the corresponding lists in + # cam_hist_config_file.F90 + _TIME_PERIODS = ['nsteps', 'nstep', 'nseconds', 'nsecond', + 'nminutes', 'nminute', 'nhours', 'nhour', 'ndays', 'nday', + 'monthly', 'nmonths', 'nmonth', 'nyears', 'nyear', + 'steps', 'seconds', 'minutes', 'hours', + 'days', 'months', 'years'] + + _OUT_PRECS = ['REAL32', 'REAL64'] + + def __init__(self, entry_string, entry_check_fn, process_fn): + """Set the entry string regular expression and value check function + for this history configuration entry type + is the name of the command + checks the command data for this config command + processes an entry in the context of a particular + HistoryConfig object. + """ + self.__name = entry_string.strip().lower() + self.__entry_regexp = re.compile(self.name + self.__HIST_VOL, + re.IGNORECASE) + self.__entry_check_fn = entry_check_fn + self.__process_fn = process_fn + # Check that name matches pattern + nmatch = self.__HIST_CONF_ENTRY_RE.match(self.name) + if (not nmatch) or (len(nmatch.group(0)) != len(self.name)): + emsg = "'{}' is not a valid HistConfigEntry name" + raise ValueError(emsg.format(self.name)) + # end if + + def get_entry(self, line): + """If matches this object's command expression, return a + tuple with the entry value and history file number (or None if no + file number is present). + Otherwise, return None. + Also, return an error string or None if no error is found. + >>> HistConfigEntry(r"hist_add_avg_fields", _list_of_idents, \ + HistoryVolConfig.add_avg_fields).get_entry("foo") + (None, "Invalid hist_add_avg_fields history config line, 'foo'") + >>> HistConfigEntry(r"hist_add_avg_fields", _list_of_idents, \ + HistoryVolConfig.add_avg_fields).get_entry("hist_add_avg_fields: foo, bar") + ((['foo', 'bar'], None), None) + >>> HistConfigEntry(r"hist_add_min_fields", _list_of_idents, \ + HistoryVolConfig.add_min_fields).get_entry("hist_add_min_fields;h5: foo, bar") + ((['foo', 'bar'], 'h5'), None) + >>> HistConfigEntry(r"hist_add_min_fields", _list_of_idents, \ + HistoryVolConfig.add_min_fields).get_entry("hist_add_min_fields;5: foo, bar") + (None, "Invalid hist_add_min_fields history config line, 'hist_add_min_fields;5: foo, bar'") + >>> HistConfigEntry(r"hist_add_avg_fields", _list_of_idents, \ + HistoryVolConfig.add_avg_fields).get_entry("hist_add_avg_fields;h1: MOE, LARRY, CURLY") + ((['MOE', 'LARRY', 'CURLY'], 'h1'), None) + """ + ematch = self.__entry_regexp.match(line.strip()) + if ematch is not None: + vol = ematch.group(1) + entry_val, errmsg = self.__entry_check_fn(ematch.group(2)) + if entry_val: + entry = (entry_val, vol) + else: + entry = None + # end if + else: + entry = None + errmsg = "Invalid {} history config line, '{}'".format(self.name, + line.strip()) + # end if + return entry, errmsg + + def process_data(self, hist_config, data, pobj, logger): + """Process according to the rules for this history configuration + command in the context of the object. + Return the value from __process_fn + """ + return self.__process_fn(hist_config, data, pobj, logger) + + @property + def name(self): + """Return the command string for this HistConfigEntry object""" + return self.__name + + @classmethod + def find_command(cls, line): + """Return the HistConfigEntry name string from if the + beginning of matches the correct pattern. + Otherwise, return the empty string. + >>> HistConfigEntry.find_command(" add_avg_fields: foo") + 'add_avg_fields' + >>> HistConfigEntry.find_command(" add_avg_fields3: foo") + 'add_avg_fields' + >>> HistConfigEntry.find_command("! add_avg_fields3: foo") + '' + """ + cmatch = cls.__HIST_CONF_ENTRY_RE.match(line.strip()) + if cmatch: + return cmatch.group(0) + # end if + return '' + +############################################################################## +class HistoryVolConfig(): +############################################################################## + """Object to hold all history configuration for a history file (volume). + """ + + # Note, variable values below must match those in cam_hist_config_file.F90 + # (without leading undescores) + __UNSET_C = 'UNSET' + __SAT_FILE = "satellite" + __INITIAL_FILE = "initial_value" + + def __init__(self, volume, file_type="history"): + """Initialize a HistoryConfig object to a default state. + is the history file descriptor (e.g., h1, i) + """ + self.__volume = volume + self.__inst_fields = HistFieldList(self.volume, 'inst', 'instantaneous') + self.__avg_fields = HistFieldList(self.volume, 'avg', 'average') + self.__min_fields = HistFieldList(self.volume, 'min', 'minimum sampled') + self.__max_fields = HistFieldList(self.volume, 'max', 'maximum sampled') + self.__var_fields = HistFieldList(self.volume, 'var', + 'variance of sampled') + self.__all_fields = [self.__inst_fields, self.__avg_fields, + self.__min_fields, self.__max_fields, + self.__var_fields] + self.__precision = 'REAL32' + if self.__volume == 'h0': + self.__max_frames = 1 + self.__output_freq = (1, 'month') + else: + self.__max_frames = 30 + self.__output_freq = (1, 'day') + # end if + self.__file_type = file_type + self.__collect_patch_output = False + self.__interp_out = False + self.__interp_nlat = 0 + self.__interp_nlon = 0 + self.__interp_grid = self.__UNSET_C + self.__interp_type = self.__UNSET_C + # Utility variables + self.__last_field_ok = True + self.__last_field_only = False + + def add_inst_fields(self, fields, pobj, logger): + """Add one or more instantaneous (last sampled value)_fields to this + HistoryVolConfig object. + Return True if it was okay to add to list of last fields. + """ + if self.__last_field_ok: + add_ok = self.__inst_fields.add_fields(fields, self.__all_fields, + pobj, logger) + self.__last_field_only |= add_ok + else: + emsg = "Attempt to add 'inst' fields to a history volume with " \ + "non-'inst' fields" + pobj.add_syntax_error(emsg) + # end if + return self.__last_field_ok + + def add_avg_fields(self, fields, pobj, logger): + """Add one or more time-averaged fields to this HistoryVolConfig + object. + Return True if it was okay to add to list of avg fields. + """ + if not self.__last_field_only: + add_ok = self.__avg_fields.add_fields(fields, self.__all_fields, + pobj, logger) + self.__last_field_ok &= (not add_ok) + else: + emsg = "Attempt to add 'avg' fields to a history volume with " \ + "'inst' fields" + pobj.add_syntax_error(emsg) + # end if + return not self.__last_field_only + + def add_min_fields(self, fields, pobj, logger): + """Add one or more min_fields to this HistoryVolConfig object. + Return True if it was okay to add to list of min fields. + """ + if not self.__last_field_only: + add_ok = self.__min_fields.add_fields(fields, self.__all_fields, + pobj, logger) + self.__last_field_ok &= (not add_ok) + else: + emsg = "Attempt to add 'min' fields to a history volume with " \ + "'inst' fields" + pobj.add_syntax_error(emsg) + # end if + return not self.__last_field_only + + def add_max_fields(self, fields, pobj, logger): + """Add one or more max_fields to this HistoryVolConfig object. + Return True if it was okay to add to list of max fields. + """ + if not self.__last_field_only: + add_ok = self.__max_fields.add_fields(fields, self.__all_fields, + pobj, logger) + self.__last_field_ok &= (not add_ok) + else: + emsg = "Attempt to add 'max' fields to a history volume with " \ + "'inst' fields" + pobj.add_syntax_error(emsg) + # end if + return not self.__last_field_only + + def add_var_fields(self, fields, pobj, logger): + """Add one or more var_fields to this HistoryVolConfig object. + Return True if it was okay to add to list of var fields. + """ + if not self.__last_field_only: + add_ok = self.__var_fields.add_fields(fields, self.__all_fields, + pobj, logger) + self.__last_field_ok &= (not add_ok) + else: + emsg = "Attempt to add 'var' fields to a history volume with " \ + "'inst' fields" + pobj.add_syntax_error(emsg) + # end if + return not self.__last_field_only + + def remove_fields(self, fields, pobj, logger): + """Remove each field in from whatever list it is on. + Return True if each field was found (and removed).""" + fields_to_delete = set(fields) + for fld_list in self.__all_fields: + removed = fld_list.remove_fields(fields_to_delete, pobj, logger) + fields_to_delete -= removed + # end for + if fields_to_delete: + ctx = context_string(pobj) + lmsg = "Fields ({}) not removed from {} (not found){}" + logger.warning(lmsg.format(", ".join(list(fields_to_delete)), + self.volume, ctx)) + # end if + return not fields_to_delete + + @property + def volume(self): + """Return the volume for this HistoryVolConfig object""" + return self.__volume + + @property + def precision(self): + """Return the precision property for this HistoryVolConfig object""" + return self.__precision + + def set_precision(self, prec, pobj, logger): + """Modify the precision property of this HistoryVolConfig object. + Return True if is a recognized precision""" + if prec in HistConfigEntry._OUT_PRECS: + self.__precision = prec + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug("Setting precision to '{}'{}".format(prec, ctx)) + # end if + return True + # end if + emsg = "Attempt to set unrecognized precision, '{}'" + pobj.add_syntax_error(emsg.format(prec)) + return False + + @property + def max_frames(self): + """Return the max_frames property for this HistoryVolConfig object""" + return self.__max_frames + + def set_max_frames(self, nframes, pobj, logger): + """Modify the max_frames property of this HistoryVolConfig object. + Return True if is a valid setting.""" + nframes_ok = True + nframes_i, _ = _is_integer(nframes) + nframes_ok = nframes_i and (nframes > 0) + if nframes_ok: + self.__max_frames = nframes_i + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug("Setting max frames to '{}'{}".format(nframes, + ctx)) + # end if + else: + emsg = "Attempt to set max frames to '{}', must be positive integer" + pobj.add_syntax_error(emsg.format(nframes)) + # end if + return nframes_ok + + def outfreq_str(self): + """Return the output_frequency for this HistoryVolConfig object + as a string""" + if isinstance(self.__output_freq, tuple): + return "{}*{}".format(self.__output_freq[0], self.__output_freq[1]) + else: + return str(self.__output_freq) + # end if + + @property + def output_frequency(self): + """Return the output_frequency property for this + HistoryVolConfig object""" + return self.__output_freq + + def set_output_frequency(self, ofreq, pobj, logger): + """Modify the output_frequency property of this HistoryVolConfig + object. is a tuple consisting of an integer and a period. + """ + if ( isinstance(ofreq, tuple) and (len(ofreq) == 2) and + isinstance(ofreq[0], int) and isinstance(ofreq[1], str) and + (ofreq[0] > 0) and + (ofreq[1].strip() in HistConfigEntry._TIME_PERIODS)): + self.__output_freq = ofreq + return True + # end if + emsg = "Attempt to set unrecognized output_frequency, '{}'" + pobj.add_syntax_error(emsg.format(ofreq)) + return False + + @property + def file_type(self): + """Return the file_type property for this HistoryVolConfig object""" + return self.__file_type + + def set_file_type(self, ftype, pobj, logger): + """Modify the file_type property of this HistoryVolConfig object""" + self.__file_type = ftype + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug("Setting file type to '{}'{}".format(ftype, ctx)) + # end if + return True + + def num_fields(self, fld_type): + """Return the number of fields for field list type, .""" + num_flds = 0 + if fld_type == 'avg': + num_flds = self.__avg_fields.num_fields() + elif fld_type == 'inst': + num_flds = self.__inst_fields.num_fields() + elif fld_type == 'min': + num_flds = self.__min_fields.num_fields() + elif fld_type == 'max': + num_flds = self.__max_fields.num_fields() + elif fld_type == 'var': + num_flds = self.__var_fields.num_fields() + else: + raise ParseInternalError("Unknown fld_type, '{}'".format(fld_type)) + # end if + return num_flds + + def output_config_namelist(self, outfile): + """Write the fortran namelist object for this HistoryVolConfig + object""" + outfile.write("\n&hist_file_config_nl\n") + outfile.write(" hist_volume = '{}'\n".format(self.volume)) + self.__inst_fields.output_nl_fieldlist(outfile, "hist_inst_fields") + self.__avg_fields.output_nl_fieldlist(outfile, "hist_avg_fields") + self.__min_fields.output_nl_fieldlist(outfile, "hist_min_fields") + self.__max_fields.output_nl_fieldlist(outfile, "hist_max_fields") + self.__var_fields.output_nl_fieldlist(outfile, "hist_var_fields") + outfile.write(" hist_max_frames = {}\n".format(self.__max_frames)) + outfile.write(" hist_output_frequency = '{}'\n".format(self.outfreq_str())) + outfile.write(" hist_precision = '{}'\n".format(self.__precision)) + outfile.write(" hist_file_type = '{}'\n".format(self.__file_type)) + outfile.write("/\n") + +############################################################################## +### Objects for identifying and processing history config commands +############################################################################## + +_HIST_CONFIG_ENTRY_TYPES = [HistConfigEntry(r"hist_add_avg_fields", + _list_of_idents, + HistoryVolConfig.add_avg_fields), + HistConfigEntry(r"hist_add_inst_fields", + _list_of_idents, + HistoryVolConfig.add_inst_fields), + HistConfigEntry(r"hist_add_min_fields", + _list_of_idents, + HistoryVolConfig.add_min_fields), + HistConfigEntry(r"hist_add_max_fields", + _list_of_idents, + HistoryVolConfig.add_max_fields), + HistConfigEntry(r"hist_add_var_fields", + _list_of_idents, + HistoryVolConfig.add_var_fields), + HistConfigEntry(r"hist_max_frames", _is_integer, + HistoryVolConfig.set_max_frames), + HistConfigEntry(r"hist_output_frequency", + _is_mult_period, + HistoryVolConfig.set_output_frequency), + HistConfigEntry(r"hist_precision", _is_prec_str, + HistoryVolConfig.set_precision), + HistConfigEntry(r"hist_diag_file", _is_filename, + None), + HistConfigEntry(r"hist_remove_fields", + _list_of_idents, + HistoryVolConfig.remove_fields)] + +_HIST_CONFIG_ENTRY_OBJS = {x.name : x for x in _HIST_CONFIG_ENTRY_TYPES} + +############################################################################## +class HistoryConfig(dict): +############################################################################## + """Object to hold the history configuration for all history files (volumes). + """ + + def __init__(self, filename=None, logger=None): + """Initialize this HistoryConfig object as an empty dictionary. + If (and ) are present, initialize this object with + the contents of + """ + if filename: + if not logger: + raise ParseInternalError("Logger required to parse file") + # end if + ret = self.parse_hist_config_file(filename, logger) + # end if (no else, just leave empty dictionary) + + def parse_hist_config_line(self, line, no_command_ok=False): + """Parse if it is a valid history config command line. + Parse the history configuration command found in . + Return three arguments: + The history config command + A tuple with the command value and command unit number (or None) + An error message if one was generated during parsing or None if no + error was found. + If is not recognized as a valid history config command line, and + is True, then None is returned as the entry and the + error message. + If is not recognized as a valid history config command line, and + is False, then None is returned as the entry and an + error message is returned. + >>> HistoryConfig().parse_hist_config_line("hist_add_avg_fields: T, U, V, PS") + ('hist_add_avg_fields', (['T', 'U', 'V', 'PS'], None), None) + >>> HistoryConfig().parse_hist_config_line("hist_add_inst_fields;h2: T, U, V, PS") + ('hist_add_inst_fields', (['T', 'U', 'V', 'PS'], 'h2'), None) + >>> HistoryConfig().parse_hist_config_line("hist_add_avg_fields;h5: foo, bar") + ('hist_add_avg_fields', (['foo', 'bar'], 'h5'), None) + >>> HistoryConfig().parse_hist_config_line("use_topo_file = .false.") + ('use_topo_file', None, "Invalid history config line, 'use_topo_file = .false.'") + >>> HistoryConfig().parse_hist_config_line("use_topo_file = .false.", no_command_ok=True) + ('use_topo_file', None, None) + """ + # Find the possible history configuration command for . + sline = line.strip() + cmd = HistConfigEntry.find_command(sline) + if cmd in _HIST_CONFIG_ENTRY_OBJS: + # We have a history configuration command, parse it + hconfig = _HIST_CONFIG_ENTRY_OBJS[cmd] + entry, errmsg = hconfig.get_entry(sline) + elif no_command_ok: + entry = None + errmsg = None + else: + # Comments and blank lines are okay + entry = None + if (not sline) or (sline[0] == '!'): + cmd = None + errmsg = None + else: + errmsg = "Invalid history config line, '{}'".format(sline) + # end if + # end if + return cmd, entry, errmsg + + def parse_hist_config_file(self, filename, logger, volume=None): + """Parse the history configuration commands from and store + the resulting configuration information. + There are two modes of parsing. + If is None, every history configuration command *must* have a + volume name or history unit number. must be a + dictionary of HistoryConfig objects keyed by volume. + If is not None, no history configuration command may have a + volume name or history unit number. must be a + single HistoryConfig object. + Typically, volume will be set except for user_nl_cam files. + """ + # Store directory information for relative paths + file_dir = os.path.dirname(os.path.abspath(filename)) + no_comm_ok = volume is None # Can have mixed lines for user_nl_cam + with open(filename, "r") as cfile: + clines = cfile.readlines() + for index, line in enumerate(clines): + clines[index] = line.strip() + # End for + # end with + # create a parse object and context for this file + pobj = ParseObject(filename, clines) + curr_line, linenum = pobj.curr_line() + while pobj.valid_line(): + args = self.parse_hist_config_line(curr_line, + no_command_ok=no_comm_ok) + cmd, entry, errmsg = args + hist_config = None + if errmsg: + pobj.add_syntax_err(errmsg) + elif entry: + cmd_val, fnum = entry + # Find a hist_config + if volume and fnum and (volume != fnum): + # This is an error + errmsg = "Volume information not allowed in {}," + errmsg += "\n{}".format(curr_line) + pobj.add_syntax_err(errmsg.format(filename)) + elif volume: + if volume not in self: + # Someone made a boo boo + ctx = context_string(pobj) + emsg = "volume, '{}', not in configs{}" + raise ParseInternalError(emsg.format(volume, ctx)) + # end if + hist_config = self[volume] + fnum = volume + elif fnum: + if fnum in self: + hist_config = self[fnum] + else: + hist_config = HistoryVolConfig(fnum) + self[fnum] = hist_config + # end if + else: + errmsg = "Volume information required in {}," + errmsg += "\n{}".format(curr_line) + pobj.add_syntax_err(errmsg.format(filename)) + # end if + else: + if (not no_comm_ok) and (not blank_config_line(curr_line)): + # Something has gone wrong. + ctx = context_string(pobj) + emsg = "Bad line but no error{}" + raise ParseInternalError(emsg.format(ctx)) + # end if + # end if + if hist_config: + # Process this line's information + if cmd == 'hist_diag_file': + if os.path.exists(cmd_val): + dfile = cmd_val + elif not os.path.isabs(cmd_val): + # Try to find the file relative to this file's directory + dfile = os.path.abspath(os.path.join(file_dir, cmd_val)) + else: + dfile = "" + # end if + if os.path.exists(dfile): + lmsg = "Processing {} for history volume {}" + logger.debug(lmsg.format(dfile, fnum)) + self.parse_hist_config_file(dfile, logger, volume=fnum) + else: + ctx = context_string(pobj) + emsg = "History config file, '{}', not found{}" + raise HistoryConfigError(emsg.format(cmd_val, ctx)) + # end if + else: + hconf_entry = _HIST_CONFIG_ENTRY_OBJS[cmd] + entry_ok = hconf_entry.process_data(hist_config, cmd_val, + pobj, logger) + # end if + # end if (no else, any error was already generated) + # Done with this line, move on + curr_line, linenum = pobj.next_line() + # end while + if pobj.error_message: + # Time to dump out error messages + raise HistoryConfigError(pobj.error_message) + # end if + return True + + def max_num_fields(self, fld_type): + """Return the maximum number of fields for on any history + volume.""" + nums_flds = [x.num_fields(fld_type) for x in self.values()] + return max(nums_flds) + + def output_class_namelist(self, ofile): + """Write the master class namelist (e.g., num fields)""" + ofile.write("\n&hist_config_arrays_nl\n"); + num_fields = self.max_num_fields('inst') + ofile.write(" hist_num_inst_fields = {}\n".format(num_fields)); + num_fields = self.max_num_fields('avg') + ofile.write(" hist_num_avg_fields = {}\n".format(num_fields)); + num_fields = self.max_num_fields('min') + ofile.write(" hist_num_min_fields = {}\n".format(num_fields)); + num_fields = self.max_num_fields('max') + ofile.write(" hist_num_max_fields = {}\n".format(num_fields)); + num_fields = self.max_num_fields('var') + ofile.write(" hist_num_var_fields = {}\n".format(num_fields)); + ofile.write("/\n"); + +############################################################################## +#IGNORE EVERYTHING BELOW HERE UNLESS RUNNING TESTS ON CAM_CONFIG! +############################################################################## + +# Call testing routine, if script is run directly +if __name__ == "__main__": + + # Import modules needed for testing + import doctest + + # Run doctests on this file's python objects + doctest.testmod() + +############# +# end of file +############# diff --git a/src/control/cam_initfiles.F90 b/src/control/cam_initfiles.F90 index cee39894..bea73de7 100644 --- a/src/control/cam_initfiles.F90 +++ b/src/control/cam_initfiles.F90 @@ -319,7 +319,7 @@ character(len=cl) function cam_initfiles_get_restdir() ! Return directory containing initial restart file - use filenames, only: get_dir + use cam_filenames, only: get_dir character(len=*), parameter :: subname = 'cam_initfiles_get_restdir' !------------------------------------------------------------------------ diff --git a/src/control/cam_instance.F90 b/src/control/cam_instance.F90 index 02e77baf..108e55f2 100644 --- a/src/control/cam_instance.F90 +++ b/src/control/cam_instance.F90 @@ -1,30 +1,32 @@ module cam_instance - implicit none - public + implicit none + private + save - integer , public :: atm_id - integer , public :: inst_index - character(len=16), public :: inst_name - character(len=16), public :: inst_suffix + integer, public :: atm_id + integer, public :: inst_index + character(len=16), public :: inst_name + character(len=16), public :: inst_suffix -!=============================================================================== +!============================================================================== CONTAINS -!=============================================================================== - - subroutine cam_instance_init(atm_id_in, inst_name_in, inst_index_in, inst_suffix_in) - - integer , intent(in) :: atm_id_in - character(len=*) , intent(in) :: inst_name_in - integer , intent(in) :: inst_index_in - character(len=*) , intent(in) :: inst_suffix_in - - ! The following sets the module variables - atm_id = atm_id_in - inst_name = inst_name_in - inst_index = inst_index_in - inst_suffix = inst_suffix_in - - end subroutine cam_instance_init +!============================================================================== + + subroutine cam_instance_init(atm_id_in, inst_name_in, inst_index_in, & + inst_suffix_in) + ! Dummy arguments + integer, intent(in) :: atm_id_in + character(len=*), intent(in) :: inst_name_in + integer, intent(in) :: inst_index_in + character(len=*), intent(in) :: inst_suffix_in + + ! The following sets the module variables + atm_id = atm_id_in + inst_name = inst_name_in + inst_index = inst_index_in + inst_suffix = inst_suffix_in + + end subroutine cam_instance_init end module cam_instance diff --git a/src/control/filenames.F90 b/src/control/filenames.F90 deleted file mode 100644 index 6344395c..00000000 --- a/src/control/filenames.F90 +++ /dev/null @@ -1,210 +0,0 @@ - module filenames - - ! Module and methods to handle filenames needed for the model. This - ! includes input filenames, and most output filenames that the model - ! uses. All filenames that the model uses will use methods or data - ! constructed by this module. In some cases (such as the cam_history module) - ! other modules or routines will store the actual filenames used, but - ! this module is used to determine the names. - - use time_manager, only: get_curr_date, get_prev_date - use shr_kind_mod, only: cl=>shr_kind_cl - use cam_control_mod, only: caseid - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - - implicit none - private - - public :: get_dir ! Get the directory name from a full path - public :: interpret_filename_spec ! Interpret a filename specifier - -!============================================================================== -CONTAINS -!============================================================================== - - character(len=cl) function get_dir(filepath) - - ! Return the directory from a filename with a full path - - ! arguments - character(len=*), intent(in) :: filepath ! Full path for a filename - - ! local variables - ! filenameposition: Character position for last character of directory - integer :: filenameposition - !------------------------------------------------------------------------ - - ! Get the directory name of the input dataset - filenameposition = index(filepath, '/', back=.true.) - if (filenameposition == 0)then - get_dir = './' - else - get_dir = filepath(1:filenameposition) - end if - - end function get_dir - - !=========================================================================== - - character(len=cl) function interpret_filename_spec(filename_spec, number, & - prev, case, yr_spec, mon_spec, day_spec, sec_spec) - - ! Create a filename from a filename specifier. The - ! filename specifyer includes codes for setting things such as the - ! year, month, day, seconds in day, caseid, and tape number. This - ! routine is private to filenames.F90 - ! - ! Interpret filename specifyer string with: - ! - ! %c for case, - ! %t for optional number argument sent into function - ! %y for year - ! %m for month - ! %d for day - ! %s for second - ! %% for the "%" character - ! - ! If the filename specifyer has spaces " ", they will be trimmed out - ! of the resulting filename. - - ! arguments - character(len=*), intent(in) :: filename_spec ! Filename specifier to use - integer, intent(in), optional :: number ! Number to use for %t field - logical, intent(in), optional :: prev ! If should label with previous time-step - character(len=*), intent(in), optional :: case ! Optional casename - integer, intent(in), optional :: yr_spec ! Simulation year - integer, intent(in), optional :: mon_spec ! Simulation month - integer, intent(in), optional :: day_spec ! Simulation day - integer, intent(in), optional :: sec_spec ! Seconds into current simulation day - - ! Local variables - integer :: year ! Simulation year - integer :: month ! Simulation month - integer :: day ! Simulation day - integer :: ncsec ! Seconds into current simulation day - character(len=cl) :: string ! Temporary character string - character(len=cl) :: format ! Format character string - integer :: i, n ! Loop variables - logical :: previous ! If should label with previous time-step - character(len=128) :: errmsg - character(len=*), parameter :: subname = 'INTERPRET_FILENAME_SPEC' - !------------------------------------------------------------------------ - - if (len_trim(filename_spec) == 0)then - call endrun (subname//': filename specifier is empty') - end if - if (index(trim(filename_spec)," ") /= 0)then - call endrun (subname//': filename specifier can not contain a space:'//trim(filename_spec)) - end if - ! - ! Determine year, month, day and sec to put in filename - ! - if (present(yr_spec) .and. present(mon_spec) .and. & - present(day_spec) .and. present(sec_spec)) then - year = yr_spec - month = mon_spec - day = day_spec - ncsec = sec_spec - else - if (.not. present(prev)) then - previous = .false. - else - previous = prev - end if - if (previous) then - call get_prev_date(year, month, day, ncsec) - else - call get_curr_date(year, month, day, ncsec) - end if - end if - ! - ! Go through each character in the filename specifyer and - ! interpret if special string - ! - i = 1 - interpret_filename_spec = '' - do while (i <= len_trim(filename_spec)) - ! - ! If following is an expansion string - ! - if (filename_spec(i:i) == "%")then - i = i + 1 - select case(filename_spec(i:i)) - case('c') ! caseid - if (present(case))then - string = trim(case) - else - string = trim(caseid) - end if - case('t') ! number - if (.not. present(number))then - write(iulog,*) subname, ': number needed in filename_spec', & - ', but not provided to subroutine' - write(iulog,*) 'filename_spec = ', trim(filename_spec) - call endrun(subname//'filename_spec = '//trim(filename_spec)) - end if - if (number > 999) then - format = '(i4.4)' - if (number > 9999) then - write(errmsg, '(2a,i0)') subname, & - ': number is too large: ', number - write(iulog, *) trim(errmsg) - call endrun(trim(errmsg)) - end if - else if (number > 99) then - format = '(i3.3)' - else if (number > 9) then - format = '(i2.2)' - else - format = '(i1.1)' - end if - write(string,format) number - case('y') ! year - if (year > 99999 ) then - format = '(i6.6)' - else if (year > 9999 ) then - format = '(i5.5)' - else - format = '(i4.4)' - end if - write(string,format) year - case('m') ! month - write(string,'(i2.2)') month - case('d') ! day - write(string,'(i2.2)') day - case('s') ! second - write(string,'(i5.5)') ncsec - case('%') ! percent character - string = "%" - case default - call endrun(subname//': Invalid expansion character: '//filename_spec(i:i)) - end select - ! - ! Otherwise take normal text up to the next "%" character - ! - else - n = index(filename_spec(i:), "%") - if (n == 0) n = len_trim(filename_spec(i:)) + 1 - if (n == 0) exit - string = filename_spec(i:n+i-2) - i = n + i - 2 - end if - if (len_trim(interpret_filename_spec) == 0)then - interpret_filename_spec = trim(string) - else - if ((len_trim(interpret_filename_spec)+len_trim(string)) >= cl) then - call endrun(subname//': Resultant filename too long') - end if - interpret_filename_spec = trim(interpret_filename_spec) // trim(string) - end if - i = i + 1 - - end do - if (len_trim(interpret_filename_spec) == 0)then - call endrun(subname//': Resulting filename is empty') - end if - - end function interpret_filename_spec - -end module filenames diff --git a/src/cpl/mct/atm_comp_mct.F90 b/src/cpl/mct/atm_comp_mct.F90 index 43d7df99..107b936f 100644 --- a/src/cpl/mct/atm_comp_mct.F90 +++ b/src/cpl/mct/atm_comp_mct.F90 @@ -43,7 +43,7 @@ module atm_comp_mct use cam_initfiles, only: cam_initfiles_get_caseid use cam_initfiles, only: cam_initfiles_get_restdir use cam_abortutils, only: endrun - use filenames, only: interpret_filename_spec + use cam_filenames, only: interpret_filename_spec use spmd_utils, only: spmd_init, masterproc, iam use time_manager, only: get_curr_calday, advance_timestep use time_manager, only: get_curr_date, get_nstep, get_step_size diff --git a/src/data/registry.xml b/src/data/registry.xml index 45e5483a..14c90126 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -39,18 +39,21 @@ allocatable="pointer"> horizontal_dimension ps state_ps + horizontal_dimension psdry state_psdry + horizontal_dimension phis state_phis + Air temperature horizontal_dimension vertical_layer_dimension T state_t + Horizontal wind in a direction perpendicular to y_wind horizontal_dimension vertical_layer_dimension u state_u + Horizontal wind in a direction perpendicular to x_wind horizontal_dimension vertical_layer_dimension v state_v + + + + + + + @@ -116,6 +122,10 @@ + + + + @@ -126,11 +136,20 @@ + + + + + + + + + @@ -149,6 +168,7 @@ + diff --git a/src/history/cam_hist_config_file.F90 b/src/history/cam_hist_config_file.F90 new file mode 100644 index 00000000..66964a24 --- /dev/null +++ b/src/history/cam_hist_config_file.F90 @@ -0,0 +1,703 @@ +module cam_hist_config_file + ! Module to define and read CAM history configuration namelist entries. + + use ISO_FORTRAN_ENV, only: REAL64, REAL32 + use cam_history_support, only: max_fldlen=>max_fieldname_len + use cam_interp_mod, only: interp_info_t=>hist_interp_info_t + + implicit none + private + + public :: hist_file_config_t + public :: hist_read_namelist_config + + character(len=*), parameter :: hist_nl_group_name = 'hist_file_config_nl' + integer, parameter :: nl_gname_len = len(hist_nl_group_name) + + logical, parameter, private :: PATCH_DEF = .true. + integer, parameter, private :: OUTPUT_DEF = REAL64 + integer, parameter, private :: vlen = 8 + integer, parameter, private :: flen = 16 + integer, parameter, private :: tlen = 16 + integer, parameter, private :: UNSET_I = -1 + character(len=vlen), parameter, private :: UNSET_C = 'UNSET' + + type :: hist_file_config_t + character(len=vlen), private :: volume = UNSET_C + integer, private :: rl_kind = OUTPUT_DEF + integer, private :: max_frames = UNSET_I + integer, private :: output_freq_mult = UNSET_I + character(len=8), private :: output_freq_type = UNSET_C + logical, private :: is_init_val_file = .false. + logical, private :: is_sat_track_file = .false. + logical, private :: collect_patch_output = PATCH_DEF + type(interp_info_t), pointer, private :: interp_info => NULL() + contains + ! Accessors + procedure :: filename => config_filename + procedure :: precision => config_precision + procedure :: max_frame => config_max_frame + procedure :: output_freq => config_output_freq + procedure :: is_initial_value_file => config_init_value_file + procedure :: is_satellite_file => config_satellite_file + ! Actions + procedure :: reset => config_reset + procedure :: configure => config_configure + procedure :: print_config => config_print_config + end type hist_file_config_t + + private :: count_array ! Number of non-blank strings in array + private :: read_namelist_entry ! Read a namelist group and create config + +CONTAINS + + ! ======================================================================== + + function config_filename(this, filename_spec) result(cfile) + use shr_kind_mod, only: CL => SHR_KIND_CL + use cam_filenames, only: interpret_filename_spec + ! Dummy arguments + class(hist_file_config_t), intent(in) :: this + character(len=*), optional, intent(in) :: filename_spec + character(len=CL) :: cfile + + if (present(filename_spec)) then + cfile = interpret_filename_spec(filename_spec, unit=this%volume) + else + cfile = this%volume + end if + + end function config_filename + + ! ======================================================================== + + function config_precision(this) result(cprec) + ! Dummy arguments + class(hist_file_config_t), intent(in) :: this + character(len=vlen) :: cprec + + if (this%rl_kind == REAL32) then + cprec = "REAL32" + else if (this%rl_kind == REAL64) then + cprec = "REAL64" + else + write(cprec, '(i0)') this%rl_kind + end if + end function config_precision + + ! ======================================================================== + + integer function config_max_frame(this) + ! Dummy argument + class(hist_file_config_t), intent(in) :: this + + config_max_frame = this%max_frames + end function config_max_frame + + ! ======================================================================== + + function config_output_freq(this) result(out_freq) + use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_string_mod, only: to_lower => shr_string_toLower + ! Dummy arguments + class(hist_file_config_t), intent(in) :: this + character(len=CL) :: out_freq + ! Local variable + character(len=CS) :: out_opt + character(len=1) :: plural + + select case(to_lower(trim(this%output_freq_type))) + case ("step") + out_opt = "time step" + case ("monthly") + out_opt = "month" + case default + out_opt = trim(this%output_freq_type) + end select + if (this%output_freq_mult > 1) then + plural = "s" + else + plural = "" + end if + write(out_freq, '(i0,1x,2a)') this%output_freq_mult, trim(out_opt), plural + + end function config_output_freq + + ! ======================================================================== + + logical function config_init_value_file(this) + ! Dummy argument + class(hist_file_config_t), intent(in) :: this + + config_init_value_file = this%is_init_val_file + + end function config_init_value_file + + ! ======================================================================== + + logical function config_satellite_file(this) + ! Dummy argument + class(hist_file_config_t), intent(in) :: this + + config_satellite_file = this%is_sat_track_file + + end function config_satellite_file + + ! ======================================================================== + + subroutine config_reset(this) + ! Dummy argument + class(hist_file_config_t), intent(inout) :: this + + this%collect_patch_output = PATCH_DEF + this%rl_kind = OUTPUT_DEF + this%max_frames = UNSET_I + this%output_freq_mult = UNSET_I + this%output_freq_type = UNSET_C + this%is_init_val_file = .false. + this%is_sat_track_file = .false. + if (associated(this%interp_info)) then + call this%interp_info%reset() + deallocate(this%interp_info) + nullify(this%interp_info) + end if + end subroutine config_reset + + ! ======================================================================== + + subroutine config_configure(this, volume, out_prec, max_frames, & + output_freq, init_file, sat_file, collect_patch_out, & + interp_out, interp_nlat, interp_nlon, interp_grid, interp_type) + use shr_kind_mod, only: CL=>SHR_KIND_CL + use shr_string_mod, only: to_lower => shr_string_toLower + use cam_abortutils, only: endrun + use string_utils, only: parse_multiplier + ! Dummy arguments + class(hist_file_config_t), intent(inout) :: this + character(len=*), intent(in) :: volume + integer, intent(in) :: out_prec + integer, intent(in) :: max_frames + character(len=*), intent(in) :: output_freq + logical, intent(in) :: init_file + logical, intent(in) :: sat_file + logical, intent(in) :: collect_patch_out + logical, optional, intent(in) :: interp_out + integer, optional, intent(in) :: interp_nlat + integer, optional, intent(in) :: interp_nlon + character(len=*), optional, intent(in) :: interp_grid + character(len=*), optional, intent(in) :: interp_type + ! Local variables + character(len=CL) :: errmsg + integer :: last_char + character(len=*), parameter :: subname = 'config_configure: ' + + call this%reset() + + this%volume = volume + this%rl_kind = out_prec + this%max_frames = max_frames + ! Parse output frequency spec into multiplier and type + ! Note, the allowed_set should match __TIME_PERIODS in hist_config.py + call parse_multiplier(output_freq, this%output_freq_mult, & + this%output_freq_type, errmsg=errmsg, & + allowed_set=(/ 'nsteps ', 'nstep ', 'nseconds', 'nsecond ', & + 'nminutes', 'nminute ', 'nhours ', 'nhour ', 'ndays ', & + 'nday ', 'monthly ', 'nmonths ', 'nmonth ', 'nyears ', & + 'nyear ', 'steps ', 'seconds ', 'minutes ', 'hours ', & + 'days ', 'months ', 'years ' /)) + if (this%output_freq_mult < 1) then + call endrun(subname//trim(errmsg), file=__FILE__, line=__LINE__-6) + end if + ! Standardize frequency type + if (to_lower(this%output_freq_type(1:1)) == "n") then + this%output_freq_type = this%output_freq_type(2:) + end if + last_char = len_trim(this%output_freq_type) + if (to_lower(this%output_freq_type(last_char:last_char)) == "s") then + this%output_freq_type = this%output_freq_type(1:last_char-1) + end if + this%is_init_val_file = init_file + this%is_sat_track_file = sat_file + this%collect_patch_output = collect_patch_out + if (present(interp_out)) then + if (interp_out) then + allocate(this%interp_info) + ! To do: write and call interp object creator + end if + end if + end subroutine config_configure + + ! ======================================================================== + + subroutine config_print_config(this) + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + ! Dummy argument + class(hist_file_config_t), intent(in) :: this + + if (masterproc) then + write(iulog, '(2a)') "History configuration for volume = ", & + trim(this%volume) + if (this%is_init_val_file) then + write(6, '(a)') " File will contain initial values" + end if + if (this%is_sat_track_file) then + write(6, '(a)') " File will contain satellite track values" + end if + if (this%rl_kind == REAL64) then + write(iulog, '(a)') " Ouput precision, 64 bits" + else if (this%rl_kind == REAL32) then + write(iulog, '(a)') " Ouput precision, 32 bits" + else + write(iulog, '(a,i0)') " Unknown output precision, ", this%rl_kind + end if + write(6, '(a,i0)') " Maximum number of output frames per file = ", & + this%max_frames + if (this%output_freq_mult == 1) then + write(6, *) " Writing output once per ", trim(this%output_freq_type) + else + write(6, '(a,i0,3a)') " Writing output every ", & + this%output_freq_mult, " ", trim(this%output_freq_type), "s" + end if + !!XXgoldyXX: Fix this when patch output is known + if (this%collect_patch_output) then + write(6, '(2a)') " Output from all patches will be collected ", & + "into a single variable" + else + write(6, '(2a)') " Output from each patch will be written ", & + "as a separate variable" + end if + if (associated(this%interp_info)) then + !!XXgoldyXX: Add interp info + end if + end if + end subroutine config_print_config + + ! ======================================================================== + + integer function count_array(arr_in) + ! Dummy argument + character(len=*), intent(in) :: arr_in(:) + ! Local variable + integer :: index + + count_array = 0 + do index = 1, size(arr_in) + if (len_trim(arr_in(index)) > 0) then + count_array = count_array + 1 + else + exit + end if + end do + end function count_array + + ! ======================================================================== + + subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & + hist_avg_fields, hist_min_fields, hist_max_fields, hist_var_fields) + use mpi, only: MPI_CHARACTER, MPI_INTEGER, MPI_LOGICAL + use string_utils, only: to_str + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc, masterprocid, mpicom + ! Read a history file configuration from and process it into + ! . + ! , , , , & + ! are provided to ensure enough room to read all namelist field entries. + ! This routine assumes that is positioned at the beginning of + ! a history file configuration namelist entry + ! Dummy arguments + integer, intent(inout) :: unitn + type(hist_file_config_t), intent(inout) :: hfile_config + character(len=*), intent(inout) :: hist_inst_fields(:) + character(len=*), intent(inout) :: hist_avg_fields(:) + character(len=*), intent(inout) :: hist_min_fields(:) + character(len=*), intent(inout) :: hist_max_fields(:) + character(len=*), intent(inout) :: hist_var_fields(:) + ! Local variables (namelist) + character(len=vlen) :: hist_volume ! h# ir i, not config number + character(len=vlen) :: hist_precision + integer :: hist_max_frames + character(len=flen) :: hist_output_frequency + logical :: hist_collect_patch_output + character(len=flen) :: hist_file_type + ! Local variables (other) + integer :: ierr + integer :: num_fields + logical :: is_sat_file + logical :: is_init_file + integer :: rl_kind + ! XXgoldyXX: Add patch information + logical :: hist_interp_out + integer :: hist_interp_nlat + integer :: hist_interp_nlon + character(len=flen) :: hist_interp_grid + character(len=flen) :: hist_interp_type + character(len=*), parameter :: subname = 'hist:read_namelist_entry: ' + + namelist /hist_file_config_nl/ hist_inst_fields, hist_avg_fields, & + hist_min_fields, hist_max_fields, hist_var_fields, hist_volume, & + hist_precision, hist_max_frames, hist_output_frequency, & + hist_file_type, hist_collect_patch_output, & + hist_interp_out, hist_interp_nlat, hist_interp_nlon, & + hist_interp_grid, hist_interp_type + + ! Initialize namelist entries to default values + hist_inst_fields(:) = '' + hist_avg_fields(:) = '' + hist_min_fields(:) = '' + hist_max_fields(:) = '' + hist_var_fields(:) = '' + hist_volume = UNSET_C ! h# ir i, not config number = + hist_precision = UNSET_C + hist_max_frames = UNSET_I + hist_output_frequency = UNSET_C + hist_collect_patch_output = .true. + hist_file_type = UNSET_C + hist_interp_out = .false. + hist_interp_nlat = 0 + hist_interp_nlon = 0 + hist_interp_grid = UNSET_C + hist_interp_type = UNSET_C + ! Read namelist entry + if (masterproc) then + read(unitn, hist_file_config_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname//"ERROR "//trim(to_str(ierr))// & + " reading namelist", file=__FILE__, line=__LINE__) +!!XXgoldyXX: v debug only + write(6, *) subname, "ERROR ", ierr, " reading namelist" + return +!!XXgoldyXX: ^ debug only + end if + ! Translate + select case(trim(hist_file_type)) + case(UNSET_C, 'history') + is_sat_file = .false. + is_init_file = .false. + case('satellite') + is_sat_file = .true. + case('initial_value') + is_init_file = .true. + case default + call endrun(subname//"ERROR, Invalid history file type, '"// & + trim(hist_file_type)//"'", file=__FILE__, line=__LINE__) + end select + ! Translat 0) then + call MPI_Bcast(hist_inst_fields(:), num_fields, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + end if + num_fields = count_array(hist_avg_fields) + if (num_fields > 0) then + call MPI_Bcast(hist_avg_fields(:), num_fields, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + end if + num_fields = count_array(hist_min_fields) + if (num_fields > 0) then + call MPI_Bcast(hist_min_fields(:), num_fields, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + end if + num_fields = count_array(hist_max_fields) + if (num_fields > 0) then + call MPI_Bcast(hist_max_fields(:), num_fields, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + end if + num_fields = count_array(hist_var_fields) + if (num_fields > 0) then + call MPI_Bcast(hist_var_fields(:), num_fields, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + end if + call MPI_Bcast(hist_volume, vlen, MPI_CHARACTER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(rl_kind, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + call MPI_Bcast(hist_max_frames, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(hist_output_frequency, flen, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + call MPI_Bcast(hist_collect_patch_output, 1, MPI_LOGICAL, & + masterprocid, mpicom, ierr) + call MPI_Bcast(is_sat_file, 1, MPI_LOGICAL, masterprocid, mpicom, ierr) + call MPI_Bcast(is_init_file, 1, MPI_LOGICAL, masterprocid, mpicom, ierr) + call MPI_Bcast(hist_interp_grid, flen, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + call MPI_Bcast(hist_interp_type, flen, MPI_CHARACTER, & + masterprocid, mpicom, ierr) + ! Configure the history file + call hfile_config%configure(hist_volume, rl_kind, hist_max_frames, & + hist_output_frequency, is_init_file, is_sat_file, & + hist_collect_patch_output, hist_interp_out, hist_interp_nlat, & + hist_interp_nlon, hist_interp_grid, hist_interp_type) + call hfile_config%print_config() + + end subroutine read_namelist_entry + + ! ======================================================================== + + subroutine allocate_field_arrays(unitn, hist_inst_fields, & + hist_avg_fields, hist_min_fields, hist_max_fields, hist_var_fields) + use mpi, only: MPI_INTEGER + use shr_kind_mod, only: SHR_KIND_CL + use shr_nl_mod, only: shr_nl_find_group_name + use cam_abortutils, only: endrun + use string_utils, only: to_str + use spmd_utils, only: mpicom, masterproc, masterprocid + use cam_abortutils, only: endrun, check_allocate + ! Read the maximum sizes of field arrays from namelist file and allocate + ! field arrays + ! Dummy arguments + integer, intent(inout) :: unitn + character(len=max_fldlen), intent(out), allocatable :: hist_inst_fields(:) + character(len=max_fldlen), intent(out), allocatable :: hist_avg_fields(:) + character(len=max_fldlen), intent(out), allocatable :: hist_min_fields(:) + character(len=max_fldlen), intent(out), allocatable :: hist_max_fields(:) + character(len=max_fldlen), intent(out), allocatable :: hist_var_fields(:) + ! Local variables + integer :: ierr + integer :: hist_num_inst_fields + integer :: hist_num_avg_fields + integer :: hist_num_min_fields + integer :: hist_num_max_fields + integer :: hist_num_var_fields + character(len=SHR_KIND_CL) :: errmsg + character(len=*), parameter :: subname = 'allocate_field_arrays' + + namelist /hist_config_arrays_nl/ hist_num_inst_fields, & + hist_num_avg_fields, hist_num_min_fields, hist_num_max_fields, & + hist_num_var_fields + + ! Initialize data + hist_num_inst_fields = 0 + hist_num_avg_fields = 0 + hist_num_min_fields = 0 + hist_num_max_fields = 0 + hist_num_var_fields = 0 + if (allocated(hist_inst_fields)) then + deallocate(hist_inst_fields) + end if + if (allocated(hist_avg_fields)) then + deallocate(hist_avg_fields) + end if + if (allocated(hist_min_fields)) then + deallocate(hist_min_fields) + end if + if (allocated(hist_max_fields)) then + deallocate(hist_max_fields) + end if + if (allocated(hist_var_fields)) then + deallocate(hist_var_fields) + end if + if (masterproc) then + rewind(unitn) + call shr_nl_find_group_name(unitn, 'hist_config_arrays_nl', ierr) + if (ierr == 0) then + read(unitn, hist_config_arrays_nl, iostat=ierr) + if (ierr /= 0) then + write(errmsg, '(2a,i0,a)') subname, ": ERROR ", ierr, & + " reading namelist, hist_config_arrays_nl" + call endrun(trim(errmsg)) +!!XXgoldyXX: v debug only + write(6, *) trim(errmsg) + return +!!XXgoldyXX: ^ debug only + end if + else + write(6, *) subname, ": WARNING, no hist_config_arrays_nl ", & + "namelist found" + end if + end if + ! Broadcast data + call MPI_Bcast(hist_num_inst_fields, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(hist_num_avg_fields, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(hist_num_min_fields, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(hist_num_max_fields, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + call MPI_Bcast(hist_num_var_fields, 1, MPI_INTEGER, masterprocid, & + mpicom, ierr) + ! Allocate arrays + allocate(hist_inst_fields(hist_num_inst_fields), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'hist_inst_fields', errmsg=errmsg, & + file=__FILE__, line=__LINE__-1) + allocate(hist_avg_fields(hist_num_avg_fields), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'hist_avg_fields', errmsg=errmsg, & + file=__FILE__, line=__LINE__-1) + allocate(hist_min_fields(hist_num_min_fields), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'hist_min_fields', errmsg=errmsg, & + file=__FILE__, line=__LINE__-1) + allocate(hist_max_fields(hist_num_max_fields), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'hist_max_fields', errmsg=errmsg, & + file=__FILE__, line=__LINE__-1) + allocate(hist_var_fields(hist_num_var_fields), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'hist_var_fields', errmsg=errmsg, & + file=__FILE__, line=__LINE__-1) + + end subroutine allocate_field_arrays + + ! ======================================================================== + + function hist_read_namelist_config(filename) result(config_arr) + use mpi, only: MPI_CHARACTER, MPI_INTEGER + use shr_kind_mod, only: max_str =>SHR_KIND_CXX, SHR_KIND_CS, SHR_KIND_CL + use shr_nl_mod, only: shr_nl_find_group_name + use cam_abortutils, only: endrun, check_allocate + use spmd_utils, only: masterproc, masterprocid, mpicom + use string_utils, only: to_str + ! Read all the history configuration namelist groups from + ! and return an array of config objects + ! Note: File operations are done on the root task with results + ! broadcast to other tasks. + + ! Dummy arguments + character(len=*), intent(in) :: filename + type(hist_file_config_t), pointer :: config_arr(:) + ! Local variables + integer :: unitn + integer :: read_status + integer :: ierr + integer :: line_num + integer :: lindex + integer :: num_configs + logical :: filefound + character(len=max_fldlen), allocatable :: hist_inst_fields(:) + character(len=max_fldlen), allocatable :: hist_avg_fields(:) + character(len=max_fldlen), allocatable :: hist_min_fields(:) + character(len=max_fldlen), allocatable :: hist_max_fields(:) + character(len=max_fldlen), allocatable :: hist_var_fields(:) + character(len=max_str) :: config_line + character(len=SHR_KIND_CL) :: errmsg + character(len=*), parameter :: subname = 'read_config_file' + ! Variables for reading a namelist entry + + nullify(config_arr) + unitn = -1 ! Prevent reads on error or wrong tasks + ierr = 0 + if (masterproc) then + inquire(file=trim(filename), exist=filefound) + if (.not. filefound) then + write(config_line, *) & + "ERROR: could not find history config file '", & + trim(filename), "'" + call endrun(subname//trim(config_line)) +!!XXgoldyXX: v debug only +return +!!XXgoldyXX: ^ debug only + else + open(newunit=unitn, file=trim(filename), status='old', iostat=ierr) + line_num = 0 + end if + end if + call MPI_bcast(ierr, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + if (ierr /= 0) then + write(errmsg, '(a,i0,2a)') ": Error ", ierr, " opening ", trim(filename) + call endrun(subname//trim(errmsg)) + end if + ! First, count up the number of history configs in this file + num_configs = 0 + line_num = 0 + if (masterproc .and. filefound) then + do + ! Look for an instance of the history configure group + call shr_nl_find_group_name(unitn, hist_nl_group_name, read_status) + if (read_status == 0) then + ! We found a history config, count it + num_configs = num_configs + 1 +!!XXgoldyXX: v debug only +write(6, '(a,i0)') "XXG: Found config #", num_configs +!!XXgoldyXX: ^ debug only + ! shr_nl_find_group_name leaves the file pointer at the beginning + ! of the namelist, move past for the next search + read(unitn, '(a)', iostat=read_status) config_line + ! Check that the read did not cause trouble + if (read_status > 0) then + write(config_line, '(a,i0,3a)') ": Error (", read_status, & + ") from '", trim(filename), "'" + close(unitn) + call endrun(subname//trim(config_line)) +!!XXgoldyXX: v debug only +return +!!XXgoldyXX: ^ debug only + else if (read_status < 0) then + ! We reached the end of the file, just quit + exit + end if ! No else, we just look for the next group + else + ! We are done with this file + exit + end if + end do + end if + ! All tasks allocate the history config file objects + call MPI_bcast(num_configs, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + allocate(config_arr(num_configs), stat=ierr, errmsg=errmsg) + call check_allocate(ierr, subname, 'config_arr', errmsg=errmsg, & + file=__FILE__, line=__LINE__-2) + ! Allocate the config field name arrays + call allocate_field_arrays(unitn, hist_inst_fields, hist_avg_fields, & + hist_min_fields, hist_max_fields, hist_var_fields) + ! Now, step through each config file namelist entry, read, and process + if (masterproc) then + ! Start from beginning of file + rewind(unit=unitn) + end if + do lindex = 1, num_configs + if (masterproc) then + ! Look for an instance of the history configure group + call shr_nl_find_group_name(unitn, hist_nl_group_name, read_status) + if (read_status /= 0) then + write(errmsg, '(2a,i0,3a)') subname, & + ": ERROR finding history config namelist #", lindex, & + " in '", trim(filename), "'" + close(unitn) + call endrun(trim(errmsg)) +!!XXgoldyXX: v debug only +write(6, *) trim(errmsg) +return +!!XXgoldyXX: ^ debug only + end if + end if + call read_namelist_entry(unitn, config_arr(lindex), & + hist_inst_fields, hist_avg_fields, hist_min_fields, & + hist_max_fields, hist_var_fields) + end do + ! + ! Cleanup + ! + ! Close unitn if it is still open + inquire(unit=unitn, opened=filefound, iostat=ierr) + if ((ierr == 0) .and. filefound) then + close(unitn) + end if + if (allocated(hist_inst_fields)) then + deallocate(hist_inst_fields) + end if + if (allocated(hist_avg_fields)) then + deallocate(hist_avg_fields) + end if + if (allocated(hist_min_fields)) then + deallocate(hist_min_fields) + end if + if (allocated(hist_max_fields)) then + deallocate(hist_max_fields) + end if + if (allocated(hist_var_fields)) then + deallocate(hist_var_fields) + end if + end function hist_read_namelist_config + +end module cam_hist_config_file diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 new file mode 100644 index 00000000..e7a367b7 --- /dev/null +++ b/src/history/cam_history.F90 @@ -0,0 +1,5131 @@ +module cam_history + !---------------------------------------------------------------------------- + ! + ! The cam_history module provides the user interface for CAM's history + ! output capabilities. + ! It maintains the lists of fields that are written to each history file, + ! and the associated metadata for those fields such as descriptive names, + ! physical units, time axis properties, etc. + ! It also contains the programmer interface which provides routines that + ! are called from the physics and dynamics initialization routines to + ! define the fields that are produced by the model and are available for + ! output, and the routine that is called from the corresponding run + ! method to add the field values into a history buffer so that they + ! may be output to disk. + ! + ! There are two special history files. The initial file and the + ! satellite track file. + ! + ! Public functions/subroutines: + ! addfld, add_default + ! hist_init_files + ! history_initialized + ! write_restart_history + ! read_restart_history + ! outfld + ! wshist + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 + use shr_kind_mod, only: cl=>SHR_KIND_CL + use shr_sys_mod, only: shr_sys_flush + use perf_mod, only: t_startf, t_stopf + use spmd_utils, only: masterproc + use cam_filenames, only: interpret_filename_spec + use cam_instance, only: inst_suffix + use cam_initfiles, only: ncdata, bnd_topo + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + + use cam_history_support, only: max_fieldname_len + use cam_history_support, only: fieldname_suffix_len + use cam_history_support, only: max_chars + use cam_history_support, only: pfiles + use cam_history_support, only: fieldname_len + use cam_history_support, only: max_string_len + use cam_history_support, only: date2yyyymmdd + use cam_history_support, only: pflds + use cam_history_support, only: fieldname_lenp2 + use cam_history_support, only: sec2hms + use cam_history_support, only: field_info + use cam_history_support, only: active_entry + use cam_history_support, only: hentry + use cam_history_support, only: horiz_only + use cam_history_support, only: write_hist_coord_attrs + use cam_history_support, only: write_hist_coord_vars + use cam_history_support, only: interp_info_t + use cam_history_support, only: lookup_hist_coord_indices + use cam_history_support, only: get_hist_coord_index + use sat_hist, only: is_satfile + use solar_parms_data, only: solar_parms_define, solar_parms_write + use solar_wind_data, only: solar_wind_define, solar_wind_write + use epotential_params, only: epot_active, epot_crit_colats + + implicit none + private + save + + ! history file info + type (active_entry), pointer :: file(:) => null() ! history file + type (active_entry), target, allocatable :: history_file(:) ! history files + ! restarthistory_files is a set of files containing partially accumulated + ! history fields (e.g., an averaged field saved at mid month). + type (active_entry), target, allocatable :: restarthistory_files(:) + ! + + integer :: nfmaster = 0 ! number of fields in master field list + integer :: nflds(pfiles) ! number of fields per file + + real(r8) :: beg_time(pfiles) ! time at beginning of an averaging interval + + ! regen_hist_file is .true. for files that require a regeneration volume + logical :: regen_hist_file(pfiles) = .false. + logical :: write_file(pfiles) = .false. ! .true. to write file + ! empty_hfiles: Namelist flag indicates no default history fields + logical :: empty_hfiles = .false. + logical :: hfiles_defined = .false. ! flag indicates history contents have been defined + + character(len=cl) :: model_doi_url = '' ! Model DOI + character(len=cl) :: caseid = '' ! case ID + character(len=cl) :: ctitle = '' ! case title + ! NB: This name must match the group name in namelist_definition.xml + character(len=*), parameter :: history_namelist = 'cam_history_nl' + ! hrestpath: Full history restart pathnames + character(len=max_string_len) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) + character(len=max_string_len) :: cpath(pfiles) ! Array of current pathnames + character(len=max_string_len) :: nhfil(pfiles) ! Array of current file names + character(len=1) :: avgflag_perfile(pfiles) = (/(' ',idx=1,pfiles)/) ! per file averaging flag + character(len=16) :: logname ! user name + character(len=16) :: host ! host name + character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or + ! 'YEARLY' then write IC file + logical :: inithist_all = .false. ! Flag to indicate set of fields to be + ! included on IC file + ! .false. include only required fields + ! .true. include required *and* optional fields + character(len=fieldname_lenp2) :: fincl(pflds,pfiles) ! List of fields to add to primary h-file + character(len=max_chars) :: fincllonlat(pflds,pfiles) ! List of fields to add to primary h-file + character(len=fieldname_lenp2) :: fexcl(pflds,pfiles) ! List of fields to rm from primary h-file + ! fout_prec: List of fields to change default history output prec + character(len=fieldname_lenp2) :: fout_prec(pflds, pfiles) + character(len=fieldname_suffix_len ) :: fieldname_suffix = '&IC' ! Suffix appended to field names for IC file + + ! Allowed history averaging flags + ! This should match namelist_definition.xml => avgflag_perfile (+ ' ') + ! The presence of 'ABI' and 'XML' in this string is a coincidence + character(len=7), parameter :: HIST_AVG_FLAGS = ' ABIXML' + character(len=22) ,parameter :: LT_DESC = 'mean (over local time)' ! local time description + logical :: collect_column_output(pfiles) + + integer :: maxvarmdims=1 + ! + + ! + ! Filename specifiers for history, initial files and restart history files + ! (%c = caseid, $y = year, $m = month, $d = day, $s = seconds in day, %t = file number) + ! + character(len=max_string_len) :: rhfilename_spec = '%c.cam.rh%t.%y-%m-%d-%s.nc' ! history restart + character(len=max_string_len) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) ! filename specifyer + + + interface addfld + module procedure addfld_1d + module procedure addfld_nd + end interface addfld + + ! Needed by cam_diagnostics + public :: inithist_all + + integer :: lcltod_start(pfiles) ! start time of day for local time averaging (sec) + integer :: lcltod_stop(pfiles) ! stop time of day for local time averaging, stop > start is wrap around (sec) + + ! Functions + public :: history_readnl ! Namelist reader for CAM history + public :: history_init_restart ! Write restart history data + public :: history_write_restart ! Write restart history data + public :: history_read_restart ! Read restart history data + public :: history_write_files ! Write files out +! public :: outfld ! Output a field + public :: history_init_files ! Initialization + public :: history_initialized ! .true. iff cam history initialized + public :: history_finalize ! process history files at end of run + public :: history_write_IC ! flag to dump of IC to IC file + public :: history_addfld ! Add a field to history file + public :: history_fld_active ! .true. if a field is active on any history file + public :: history_fld_col_active ! .true. for each column where a field is active on any history file + public :: register_vector_field ! Register vector field set for interpolated output + +CONTAINS + + subroutine history_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpicom + use spmd_utils, only: mpi_integer, mpi_logical, mpi_character + use shr_string_mod, only: shr_string_toUpper + use time_manager, only: get_step_size + use sat_hist, only: sat_hist_readnl + + ! Dummy argument + character(len=*), intent(in) :: nlfile ! filepath of namelist input file + + ! + ! Local variables + integer :: dtime ! Step time in seconds + integer :: unitn, ierr, f, t + character(len=8) :: ctemp ! Temporary character string + + ! History namelist items + namelist /cam_history_nl/ & + diag_file1, diag_file2, diag_file3, diag_file4, diag_file5, & + diag_file6, diag_file7, diag_file8, diag_file9, diag_file10, & + lcltod_start, lcltod_stop, & + inithist, inithist_all, & + hfilename_spec, & + interpolate_nlat, interpolate_nlon, & + interpolate_gridtype, interpolate_type, interpolate_output + + ! Set namelist defaults (these should match initial values if given) + fincl(:,:) = ' ' + fincllonlat(:,:) = ' ' + fexcl(:,:) = ' ' + fout_prec(:,:) = ' ' + collect_column_output(:) = .false. + avgflag_perfile(:) = ' ' + ndens = 2 + hist_freq(1) = 0 + hist_freq(2:) = -24 + mfilt = 30 + inithist = 'YEARLY' + inithist_all = .false. + empty_hfiles = .false. + lcltod_start(:) = 0 + lcltod_stop(:) = 0 + hfilename_spec(:) = ' ' + interpolate_nlat(:) = 0 + interpolate_nlon(:) = 0 + interpolate_gridtype(:) = 1 + interpolate_type(:) = 1 + interpolate_output(:) = .false. + + ! Initialize namelist 'temporary variables' + do f = 1, pflds + fincl1(fld_idx) = ' ' + fincl2(fld_idx) = ' ' + fincl3(fld_idx) = ' ' + fincl4(fld_idx) = ' ' + fincl5(fld_idx) = ' ' + fincl6(fld_idx) = ' ' + fincl7(fld_idx) = ' ' + fincl8(fld_idx) = ' ' + fincl9(fld_idx) = ' ' + fincl10(fld_idx) = ' ' + fincl1lonlat(fld_idx) = ' ' + fincl2lonlat(fld_idx) = ' ' + fincl3lonlat(fld_idx) = ' ' + fincl4lonlat(fld_idx) = ' ' + fincl5lonlat(fld_idx) = ' ' + fincl6lonlat(fld_idx) = ' ' + fincl7lonlat(fld_idx) = ' ' + fincl8lonlat(fld_idx) = ' ' + fincl9lonlat(fld_idx) = ' ' + fincl10lonlat(fld_idx) = ' ' + fexcl1(fld_idx) = ' ' + fexcl2(fld_idx) = ' ' + fexcl3(fld_idx) = ' ' + fexcl4(fld_idx) = ' ' + fexcl5(fld_idx) = ' ' + fexcl6(fld_idx) = ' ' + fexcl7(fld_idx) = ' ' + fexcl8(fld_idx) = ' ' + fexcl9(fld_idx) = ' ' + fexcl10(fld_idx) = ' ' + fwrtpr1(fld_idx) = ' ' + fwrtpr2(fld_idx) = ' ' + fwrtpr3(fld_idx) = ' ' + fwrtpr4(fld_idx) = ' ' + fwrtpr5(fld_idx) = ' ' + fwrtpr6(fld_idx) = ' ' + fwrtpr7(fld_idx) = ' ' + fwrtpr8(fld_idx) = ' ' + fwrtpr9(fld_idx) = ' ' + fwrtpr10(fld_idx) = ' ' + end do + + if (trim(history_namelist) /= 'cam_history_nl') then + call endrun('HISTORY_READNL: CAM history namelist mismatch') + end if + if (masterproc) then + write(iulog, *) 'Read in ',history_namelist,' namelist from: ',trim(nlfile) + unitn = getunit() + open(unitn, file=trim(nlfile), status='old') + call find_group_name(unitn, history_namelist, status=ierr) + if (ierr == 0) then + read(unitn, cam_history_nl, iostat=ierr) + if (ierr /= 0) then + call endrun('history_readnl: ERROR reading namelist, '//trim(history_namelist)) + end if + end if + close(unitn) + call freeunit(unitn) + + do f = 1, pflds + fincl(f, 1) = fincl1(fld_idx) + fincl(f, 2) = fincl2(fld_idx) + fincl(f, 3) = fincl3(fld_idx) + fincl(f, 4) = fincl4(fld_idx) + fincl(f, 5) = fincl5(fld_idx) + fincl(f, 6) = fincl6(fld_idx) + fincl(f, 7) = fincl7(fld_idx) + fincl(f, 8) = fincl8(fld_idx) + fincl(f, 9) = fincl9(fld_idx) + fincl(f,10) = fincl10(fld_idx) + + fincllonlat(f, 1) = fincl1lonlat(fld_idx) + fincllonlat(f, 2) = fincl2lonlat(fld_idx) + fincllonlat(f, 3) = fincl3lonlat(fld_idx) + fincllonlat(f, 4) = fincl4lonlat(fld_idx) + fincllonlat(f, 5) = fincl5lonlat(fld_idx) + fincllonlat(f, 6) = fincl6lonlat(fld_idx) + fincllonlat(f, 7) = fincl7lonlat(fld_idx) + fincllonlat(f, 8) = fincl8lonlat(fld_idx) + fincllonlat(f, 9) = fincl9lonlat(fld_idx) + fincllonlat(f,10) = fincl10lonlat(fld_idx) + + fexcl(f, 1) = fexcl1(fld_idx) + fexcl(f, 2) = fexcl2(fld_idx) + fexcl(f, 3) = fexcl3(fld_idx) + fexcl(f, 4) = fexcl4(fld_idx) + fexcl(f, 5) = fexcl5(fld_idx) + fexcl(f, 6) = fexcl6(fld_idx) + fexcl(f, 7) = fexcl7(fld_idx) + fexcl(f, 8) = fexcl8(fld_idx) + fexcl(f, 9) = fexcl9(fld_idx) + fexcl(f,10) = fexcl10(fld_idx) + + fout_prec(f, 1) = fwrtpr1(fld_idx) + fout_prec(f, 2) = fwrtpr2(fld_idx) + fout_prec(f, 3) = fwrtpr3(fld_idx) + fout_prec(f, 4) = fwrtpr4(fld_idx) + fout_prec(f, 5) = fwrtpr5(fld_idx) + fout_prec(f, 6) = fwrtpr6(fld_idx) + fout_prec(f, 7) = fwrtpr7(fld_idx) + fout_prec(f, 8) = fwrtpr8(fld_idx) + fout_prec(f, 9) = fwrtpr9(fld_idx) + fout_prec(f,10) = fwrtpr10(fld_idx) + end do + + ! + ! If generate an initial conditions history file as an auxillary file: + ! + ctemp = shr_string_toUpper(inithist) + inithist = trim(ctemp) + if ( (inithist /= '6-HOURLY') .and. (inithist /= 'DAILY') .and. & + (inithist /= 'MONTHLY') .and. (inithist /= 'YEARLY') .and. & + (inithist /= 'CAMIOP') .and. (inithist /= 'ENDOFRUN')) then + inithist = 'NONE' + end if + ! + ! History file write times + ! Convert write freq. of hist files from hours to timesteps if necessary. + ! + dtime = get_step_size() + do t = 1, pfiles + if (hist_freq(fil_idx) < 0) then + hist_freq(fil_idx) = nint((-hist_freq(fil_idx) * 3600._r8) / dtime) + end if + end do + ! + ! Initialize the filename specifier if not already set + ! This is the format for the history filenames: + ! %c= caseid, %t=file no., %y=year, %m=month, %d=day, %s=second, %%=% + ! See the filenames module for more information + ! + do t = 1, pfiles + if ( len_trim(hfilename_spec(fil_idx)) == 0 )then + if ( hist_freq(fil_idx) == 0 )then + ! Monthly files + hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // '.h%t.%y-%m.nc' + else + hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // '.h%t.%y-%m-%d-%s.nc' + end if + end if + ! + ! Only one time sample allowed per monthly average file + ! + if (hist_freq(fil_idx) == 0) then + mfilt(fil_idx) = 1 + end if + end do + end if ! masterproc + + ! Print per-file averaging flags + if (masterproc) then + do t = 1, pfiles + if (avgflag_perfile(fil_idx) /= ' ') then + write(iulog,*)'Unless overridden by namelist input on a per-field basis (FINCL),' + write(iulog,*)'All fields on history file ',t,' will have averaging flag ',avgflag_perfile(fil_idx) + end if + ! Enforce no interpolation for satellite files + if (is_satfile(fil_idx) .and. interpolate_output(fil_idx)) then + write(iulog, *) 'WARNING: Interpolated output not supported for a satellite history file, ignored' + interpolate_output(fil_idx) = .false. + end if + ! Enforce no interpolation for IC files + if (is_initfile(fil_idx) .and. interpolate_output(fil_idx)) then + write(iulog, *) 'WARNING: Interpolated output not supported for an initial data (IC) history file, ignored' + interpolate_output(fil_idx) = .false. + end if + end do + end if + + ! Write out inithist info + if (masterproc) then + if (inithist == '6-HOURLY' ) then + write(iulog,*)'Initial conditions history files will be written 6-hourly.' + else if (inithist == 'DAILY' ) then + write(iulog,*)'Initial conditions history files will be written daily.' + else if (inithist == 'MONTHLY' ) then + write(iulog,*)'Initial conditions history files will be written monthly.' + else if (inithist == 'YEARLY' ) then + write(iulog,*)'Initial conditions history files will be written yearly.' + else if (inithist == 'CAMIOP' ) then + write(iulog,*)'Initial conditions history files will be written for IOP.' + else if (inithist == 'ENDOFRUN' ) then + write(iulog,*)'Initial conditions history files will be written at end of run.' + else + write(iulog,*)'Initial conditions history files will not be created' + end if + end if + + ! Print out column-output information + do t = 1, size(fincllonlat, 2) + if (ANY(len_trim(fincllonlat(:,t)) > 0)) then + if (collect_column_output(fil_idx)) then + write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, columns will be collected into ncol dimension' + else + write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, patches will be written to individual variables' + end if + end if + end do + + ! Broadcast namelist variables + call mpi_bcast(ndens, pfiles, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(hist_freq, pfiles, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(mfilt, pfiles, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(inithist,len(inithist), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(inithist_all,1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(lcltod_start, pfiles, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(lcltod_stop, pfiles, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(collect_column_output, pfiles, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(empty_hfiles,1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(avgflag_perfile, pfiles, mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(hfilename_spec, len(hfilename_spec(1))*pfiles, mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(fincl, len(fincl (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(fexcl, len(fexcl (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) + + call mpi_bcast(fincllonlat, len(fincllonlat (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) + + call mpi_bcast(fout_prec, len(fout_prec(1,1))*pflds*pfiles, & + mpi_character, masterprocid, mpicom, ierr) + t = size(interpolate_nlat, 1) + call mpi_bcast(interpolate_nlat, t, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(interpolate_nlon, t, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(interpolate_gridtype, t, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(interpolate_type, t, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(interpolate_output, pfiles, mpi_logical, masterprocid, mpicom, ierr) + + ! Setup the interpolate_info structures + do t = 1, size(interpolate_info) + interpolate_info(fil_idx)%interp_type = interpolate_type(fil_idx) + interpolate_info(fil_idx)%interp_gridtype = interpolate_gridtype(fil_idx) + interpolate_info(fil_idx)%interp_nlat = interpolate_nlat(fil_idx) + interpolate_info(fil_idx)%interp_nlon = interpolate_nlon(fil_idx) + end do + + ! separate namelist reader for the satellite history file + call sat_hist_readnl(nlfile, hfilename_spec, mfilt, fincl, hist_freq, avgflag_perfile) + + end subroutine history_readnl + + !=========================================================================== + + subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Initialize history file handler for initial or continuation + ! run. + ! For example, on an initial run, this routine initializes + ! the configured history files. On a restart run, this routine + ! only initializes history files declared beyond what existed + ! on the previous run. Files which already existed on the + ! previous run have already been initialized (i.e. named and + ! opened) in routine, hist_initialize_restart + ! + !----------------------------------------------------------------------- + use shr_sys_mod, only: shr_sys_getenv + use time_manager, only: get_prev_time, get_curr_time + use cam_control_mod, only: restart_run, branch_run + use sat_hist, only: sat_hist_init + use spmd_utils, only: mpicom, masterprocid, mpi_character + ! + !----------------------------------------------------------------------- + ! + ! Dummy argument + ! + character(len=cl), intent(in) :: model_doi_url_in + character(len=cl), intent(in) :: caseid_in + character(len=cl), intent(in) :: ctitle_in + ! + ! Local workspace + ! + integer :: file, fld_ind ! file, field indices + integer :: begdim1 ! on-node dim1 start index + integer :: enddim1 ! on-node dim1 end index + integer :: begdim2 ! on-node dim2 start index + integer :: enddim2 ! on-node dim2 end index + integer :: begdim3 ! on-node chunk or lat start index + integer :: enddim3 ! on-node chunk or lat end index + integer :: day, sec ! day and seconds from base date + integer :: rcode ! shr_sys_getenv return code + type(master_entry), pointer :: listentry + character(len=32) :: fldname + + ! + ! Save the DOI + ! + model_doi_url = trim(model_doi_url_in) + caseid = caseid_in + ctitle = ctitle_in + + ! + ! Print master field list + ! + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*)' ******* MASTER FIELD LIST *******' + end if + listentry=>masterlinkedlist + fld_ind = 0 + do while(associated(listentry)) + fld_ind = fld_ind + 1 + if(masterproc) then + fldname = listentry%field%name + write(iulog,9000) fld_ind, fldname, listentry%field%units, & + listentry%field%numlev, listentry%avgflag(1), & + trim(listentry%field%long_name) +9000 format(i5, 1x, a32, 1x, a16, 1x, i4, 1x, a1, 2x, a) + end if + listentry=>listentry%next_entry + end do + nfmaster = fld_ind + if (masterproc) then + write(iulog,*) 'hist_init_files: nfmaster=', nfmaster + end if + + ! + ! Now that masterlinkedlist is defined and we are performing a + ! restart run (after all addfld calls), construct primary and + ! secondary hashing tables. + ! + if (restart_run) then + call print_active_field_list() + call bld_outfld_hash_tbls() + call bld_hfilefld_indices() + return + end if + ! + ! Get users logname and machine hostname + ! + if (masterproc) then + logname = ' ' + call shr_sys_getenv ('LOGNAME', logname, rcode) + host = ' ' + call shr_sys_getenv ('HOST', host, rcode) + end if + ! PIO requires netcdf attributes have consistant values on all tasks + call mpi_bcast(logname, len(logname), mpi_character, & + masterprocid, mpicom, rcode) + call mpi_bcast(host, len(host), mpi_character, & + masterprocid, mpicom, rcode) + ! + ! Override averaging flag for all fields on a particular file if namelist input so specifies + ! + do fil_idx = 1, pfiles + if (avgflag_perfile(fil_idx) /= ' ') then + call h_override (fil_idx) + end if + end do + ! + ! Define field list information for all history files. + ! + call create_field_list() + ! + ! Loop over max. no. of history files permitted + ! + if (branch_run) then + call get_prev_time(day, sec) ! elapased time since reference date + else + call get_curr_time(day, sec) ! elapased time since reference date + end if + do fil_idx = 1, pfiles + ! nfils: Number of time samples in history file file, fil_idx + nfils(fil_idx) = 0 + ! Time at beginning of current averaging interval. + beg_time(fil_idx) = day + (sec/86400._r8) + end do + + ! + ! Initialize history variables + ! + do fil_idx = 1, pfiles + do fld_idx = 1, nflds(fil_idx) + begdim1 = file(fil_idx)%hlist(fld_idx)%field%begdim1 + enddim1 = file(fil_idx)%hlist(fld_idx)%field%enddim1 + begdim2 = file(fil_idx)%hlist(fld_idx)%field%begdim2 + enddim2 = file(fil_idx)%hlist(fld_idx)%field%enddim2 + begdim3 = file(fil_idx)%hlist(fld_idx)%field%begdim3 + enddim3 = file(fil_idx)%hlist(fld_idx)%field%enddim3 + allocate(file(fil_idx)%hlist(fld_idx)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3)) + file(fil_idx)%hlist(fld_idx)%hbuf = 0._r8 + if (file(fil_idx)%hlist(fld_idx)%avgflag .eq. 'S') then ! allocate the variance buffer for standard dev + allocate(file(fil_idx)%hlist(fld_idx)%sbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3)) + file(fil_idx)%hlist(fld_idx)%sbuf = 0._r8 + endif + if(file(fil_idx)%hlist(fld_idx)%field%flag_xyfill .or. (avgflag_perfile(fil_idx) .eq. 'L')) then + allocate (file(fil_idx)%hlist(fld_idx)%nacs(begdim1:enddim1,begdim3:enddim3)) + else + allocate (file(fil_idx)%hlist(fld_idx)%nacs(1,begdim3:enddim3)) + end if + file(fil_idx)%hlist(fld_idx)%nacs(:,:) = 0 + file(fil_idx)%hlist(fld_idx)%field%meridional_complement = -1 + file(fil_idx)%hlist(fld_idx)%field%zonal_complement = -1 + end do + end do + ! Setup vector pairs for unstructured grid interpolation + call setup_interpolation_and_define_vector_complements() + ! Initialize the sat following history subsystem + call sat_hist_init() + + return + end subroutine hist_init_files + + logical function history_initialized() + history_initialized = associated(masterlist) + end function history_initialized + + !=========================================================================== + + subroutine set_field_dimensions(field) + use cam_history_support, only: hist_coord_size + use cam_grid_support, only: cam_grid_get_array_bounds, cam_grid_is_block_indexed + ! Dummy arguments + type(field_info), intent(inout) :: field + + ! Local variables + integer :: i + integer :: msize + integer :: dimbounds(2,2) + + call cam_grid_get_array_bounds(field%decomp_type, dimbounds) + field%begdim1 = dimbounds(1,1) + field%enddim1 = dimbounds(1,2) + field%begdim2 = 1 + if (associated(field%mdims)) then + if (size(field%mdims) > 0) then + field%enddim2 = 1 + do i = 1, size(field%mdims) + msize = hist_coord_size(field%mdims(i)) + if (msize <= 0) then + call endrun('set_field_dimensions: mdim size must be > 0') + end if + field%enddim2 = field%enddim2 * msize + end do + else + if (field%numlev < 1) then + if (masterproc) then + write(iulog, *) 'SET_FIELD_DIMENSIONS WARNING: illegal numlev for ', trim(field%name) + end if + field%numlev = 1 + end if + field%enddim2 = field%numlev + end if + else + if (field%numlev < 1) then + if (masterproc) then + write(iulog, *) 'SET_FIELD_DIMENSIONS WARNING: illegal numlev for ', trim(field%name) + end if + field%numlev = 1 + end if + field%enddim2 = field%numlev + end if + field%begdim3 = dimbounds(2,1) + field%enddim3 = dimbounds(2,2) + field%colperchunk = cam_grid_is_block_indexed(field%decomp_type) + + end subroutine set_field_dimensions + + subroutine setup_interpolation_and_define_vector_complements() + use interp_mod, only: setup_history_interpolation + + ! Local variables + integer :: hf, f, ff + logical :: interp_ok + character(len=max_fieldname_len) :: fname + character(len=max_fieldname_len) :: mname + character(len=max_fieldname_len) :: zname + character(len=*), parameter :: subname='setup_interpolation_and_define_vector_complements' + + ! Do not interpolate IC history and sat hist files + if (any(interpolate_output)) then + call setup_history_interpolation(interp_ok, pfiles-2, & + interpolate_output, interpolate_info) + do hf = 1, pfiles - 2 + if((.not. is_satfile(hf)) .and. (.not. is_initfile(hf))) then + do fld_idx = 1, nflds(hf) + fname = trim(file(hf)%hlist(fld_idx)%field%name) + if (field_part_of_vector(fname, mname, zname)) then + if (len_trim(mname) > 0) then + ! This field is a zonal part of a set, + ! find the meridional partner + do ff = 1, nflds(hf) + if ( trim(mname) == & + trim(file(hf)%hlist(ff)%field%name)) then + file(hf)%hlist(fld_idx)%field%meridional_complement = ff + file(hf)%hlist(ff)%field%zonal_complement = f + exit + end if + if (ff == nflds(hf)) then + call endrun(subname//': No meridional match for '//fname) + end if + end do + else if (len_trim(zname) > 0) then + ! This field is a meridional part of a set, + ! find the zonal partner + do ff = 1, nflds(hf) + if ( trim(zname) == & + trim(file(hf)%hlist(ff)%field%name)) then + file(hf)%hlist(fld_idx)%field%zonal_complement = ff + file(hf)%hlist(ff)%field%meridional_complement = f + exit + end if + if (ff == nflds(hf)) then + call endrun(subname//': No zonal match for '//fname)) + end if + end do + else + call endrun(subname//': INTERNAL ERROR, bad vector field') + end if + end if + end do + end if + end do + end if + end subroutine setup_interpolation_and_define_vector_complements + + !####################################################################### + + subroutine init_restart_history (fil_idx) + use cam_pio_utils, only: cam_pio_def_dim + use cam_pio_utils, only: cam_pio_handle_error + + !------------------------------------------------------------------------ + ! + ! Arguments + ! + type(file_desc_t), intent(inout) :: File ! Pio file Handle + ! + ! Local + ! + integer :: dimids(4), ndims + integer :: ierr, i, k + + ! Don't need to write restart data if we have written the file this step + where (write_file(:)) + regen_hist_file(:) = .false. + elsewhere + regen_hist_file(:) = .true. + end where + + end subroutine init_restart_history + + !####################################################################### + + subroutine write_restart_history(File, & + yr_spec, mon_spec, day_spec, sec_spec) + + !------------------------------------------------------------------------ + ! + ! Arguments + ! + type(file_desc_t), intent(inout) :: file ! PIO restart file pointer + integer, intent(in), optional :: yr_spec ! Simulation year + integer, intent(in), optional :: mon_spec ! Simulation month + integer, intent(in), optional :: day_spec ! Simulation day + integer, intent(in), optional :: sec_spec ! Seconds into current sim. day + ! + ! Local workspace + ! + integer :: ierr ! PIO return valud + integer :: fil_idx ! history file index + integer :: fld_idx ! index of field on history file + integer :: regen_hist_int(pfiles) ! For writing out regen_hist_file + + integer, allocatable :: interp_output(:) + + integer :: maxnflds + + + maxnflds = maxval(nflds) + allocate(interp_output(pfiles)) + interp_output = 0 + + ! + !----------------------------------------------------------------------- + ! Write the history restart data if necessary + !----------------------------------------------------------------------- + + regen_hist_int(:) = 0 + + if( .not. allocated(restarthistory_files)) then + allocate(restarthistory_files(pfiles)) + end if + + do fil_idx = 1, pfiles + ! No need to write history IC restart because it is always + ! instantaneous + if (is_initfile(file_index=fil_idx)) then + regen_hist_file(fil_idx) = .false. + end if + ! No need to write restart data for empty files + if (nflds(fil_idx) == 0) then + regen_hist_file(fil_idx) = .false. + end if + if(regen_hist_file(fil_idx)) then + regen_hist_int(fil_idx) = 1 + restarthistory_files(fil_idx)%hlist => history_file(fil_idx)%hlist + end if + end do + + if(maxval(nflds) <= 0) then + ! There are no history restart files to write + return + end if + + call wshist(regen_hist_file) + + file => history_file + + end subroutine write_restart_history + + + !####################################################################### + + subroutine read_restart_history (fil_idx) + use pio, only: pio_inq_dimid, pio_seterrorhandling + use pio, only: pio_inq_varid, pio_inq_dimname + use cam_pio_utils, only: cam_pio_openfile, cam_pio_closefile + use cam_pio_utils, only: cam_pio_var_info + use ioFileMod, only: getfil + use sat_hist, only: sat_hist_define, sat_hist_init + use cam_grid_support, only: cam_grid_read_dist_array + use cam_grid_support, only: cam_grid_num_grids + use cam_history_support, only: get_hist_coord_index, add_hist_coord + use constituents, only: cnst_get_ind, cnst_get_type_byind + + use shr_sys_mod, only: shr_sys_getenv + use spmd_utils, only: mpicom, mpi_character, masterprocid + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(file_desc_t), intent(inout) :: File ! unit number + ! + ! Local workspace + ! + integer t, f, ff ! file, field indices + integer begdim2 ! on-node vert start index + integer enddim2 ! on-node vert end index + integer begdim1 ! on-node dim1 start index + integer enddim1 ! on-node dim1 end index + integer begdim3 ! on-node chunk or lat start index + integer enddim3 ! on-node chunk or lat end index + + + integer regen_hist_int(pfiles) + integer :: ierr + + character(len=max_string_len) :: locfn ! Local filename + character(len=max_fieldname_len), allocatable :: tmpname(:,:) + integer, allocatable :: decomp(:,:), tmpnumlev(:,:) + integer, pointer :: nacs(:,:) ! accumulation counter + character(len=max_fieldname_len) :: fname_tmp ! local copy of field name + character(len=max_fieldname_len) :: dname_tmp ! local copy of dim name + + integer :: i, pfiles_dimid + + type(var_desc_t) :: vdesc + integer :: ndims, dimids(8) + integer :: tmpdims(8), dimcnt + integer :: dimlens(7) + integer :: mfiles, mdimcnt + integer :: fdims(3) ! Field dims + integer :: nfdims ! 2 or 3 (for 2D,3D) + integer :: fdecomp ! Grid ID for field + integer :: idx + integer :: err_handling + character(len=3) :: mixing_ratio + + ! + ! Get users logname and machine hostname + ! + if ( masterproc )then + logname = ' ' + call shr_sys_getenv ('LOGNAME',logname,ierr) + host = ' ' + call shr_sys_getenv ('HOST',host,ierr) + end if + ! PIO requires netcdf attributes have consistant values on all tasks + call mpi_bcast(logname, len(logname), mpi_character, masterprocid, & + mpicom, ierr) + call mpi_bcast(host, len(host), mpi_character, masterprocid, & + mpicom, ierr) + + call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) + + ierr = pio_inq_dimid(File, 'pfiles', pfiles_dimid) + if(ierr /= PIO_NOERR) then + if(masterproc) then + write(iulog,*) 'Not reading history info from restart file', ierr + end if + return ! no history info in restart file + end if + call pio_seterrorhandling(File, err_handling) + + ierr = pio_inq_dimlen(File, pfiles_dimid, mfiles) + + ierr = pio_inq_dimid(File, 'maxnflds', dimid) + ierr = pio_inq_dimlen(File, dimid, maxnflds) + + ierr = pio_inq_dimid(File, 'maxvarmdims', dimid) + ierr = pio_inq_dimlen(File, dimid, maxvarmdims) + + ierr = pio_inq_varid(File, 'regen_hist_file', vdesc) + ierr = pio_get_var(File, vdesc, regen_hist_int(1:mfiles)) + + ierr = pio_inq_varid(File, 'nflds', vdesc) + ierr = pio_get_var(File, vdesc, nflds(1:mfiles)) + ierr = pio_inq_varid(File, 'nfils', vdesc) + ierr = pio_get_var(File, vdesc, nfils(1:mfiles)) + ierr = pio_inq_varid(File, 'mfilt', vdesc) + ierr = pio_get_var(File, vdesc, mfilt(1:mfiles)) + + ierr = pio_inq_varid(File, 'cpath', vdesc) + ierr = pio_get_var(File, vdesc, cpath(1:mfiles)) + ierr = pio_inq_varid(File, 'nhfil', vdesc) + ierr = pio_get_var(File, vdesc, nhfil(1:mfiles)) + ierr = pio_inq_varid(File, 'hrestpath', vdesc) + ierr = pio_get_var(File, vdesc, hrestpath(1:mfiles)) + + + ierr = pio_inq_varid(File, 'ndens', vdesc) + ierr = pio_get_var(File, vdesc, ndens(1:mfiles)) + ierr = pio_inq_varid(File, 'ncprec', vdesc) + ierr = pio_get_var(File, vdesc, ncprec(1:mfiles)) + ierr = pio_inq_varid(File, 'beg_time', vdesc) + ierr = pio_get_var(File, vdesc, beg_time(1:mfiles)) + + + ierr = pio_inq_varid(File, 'fincl', vdesc) + ierr = pio_get_var(File, vdesc, fincl(:,1:mfiles)) + + ierr = pio_inq_varid(File, 'fincllonlat', vdesc) + ierr = pio_get_var(File, vdesc, fincllonlat(:,1:mfiles)) + + ierr = pio_inq_varid(File, 'fexcl', vdesc) + ierr = pio_get_var(File, vdesc, fexcl(:,1:mfiles)) + + ierr = pio_inq_varid(File, 'lcltod_start', vdesc) + ierr = pio_get_var(File, vdesc, lcltod_start(1:mfiles)) + + ierr = pio_inq_varid(File, 'lcltod_stop', vdesc) + ierr = pio_get_var(File, vdesc, lcltod_stop(1:mfiles)) + + + + + allocate(tmpname(maxnflds, mfiles), decomp(maxnflds, mfiles), tmpnumlev(maxnflds,mfiles)) + ierr = pio_inq_varid(File, 'field_name', vdesc) + ierr = pio_get_var(File, vdesc, tmpname) + + ierr = pio_inq_varid(File, 'decomp_type', vdesc) + ierr = pio_get_var(File, vdesc, decomp) + ierr = pio_inq_varid(File, 'numlev', vdesc) + ierr = pio_get_var(File, vdesc, tmpnumlev) + + allocate(tmpprec(maxnflds,mfiles)) + ierr = pio_inq_varid(File, 'hwrt_prec',vdesc) + ierr = pio_get_var(File, vdesc, tmpprec(:,:)) + + allocate(xyfill(maxnflds,mfiles)) + ierr = pio_inq_varid(File, 'xyfill', vdesc) + ierr = pio_get_var(File, vdesc, xyfill) + + allocate(is_subcol(maxnflds,mfiles)) + ierr = pio_inq_varid(File, 'is_subcol', vdesc) + ierr = pio_get_var(File, vdesc, is_subcol) + + !! interpolated output + allocate(interp_output(mfiles)) + ierr = pio_inq_varid(File, 'interpolate_output', vdesc) + ierr = pio_get_var(File, vdesc, interp_output) + interpolate_output(1:mfiles) = interp_output(1:mfiles) > 0 + if (pfiles > mfiles) then + interpolate_output(mfiles+1:pfiles) = .false. + end if + ierr = pio_inq_varid(File, 'interpolate_type', vdesc) + ierr = pio_get_var(File, vdesc, interp_output) + do t = 1, mfiles + if (interpolate_output(fil_idx)) then + interpolate_info(fil_idx)%interp_type = interp_output(fil_idx) + end if + end do + ierr = pio_inq_varid(File, 'interpolate_gridtype', vdesc) + ierr = pio_get_var(File, vdesc, interp_output) + do t = 1, mfiles + if (interpolate_output(fil_idx)) then + interpolate_info(fil_idx)%interp_gridtype = interp_output(fil_idx) + end if + end do + ierr = pio_inq_varid(File, 'interpolate_nlat', vdesc) + ierr = pio_get_var(File, vdesc, interp_output) + do t = 1, mfiles + if (interpolate_output(fil_idx)) then + interpolate_info(fil_idx)%interp_nlat = interp_output(fil_idx) + end if + end do + ierr = pio_inq_varid(File, 'interpolate_nlon', vdesc) + ierr = pio_get_var(File, vdesc, interp_output) + do t = 1, mfiles + if (interpolate_output(fil_idx)) then + interpolate_info(fil_idx)%interp_nlon = interp_output(fil_idx) + end if + end do + + !! mdim indices + allocate(allmdims(maxvarmdims,maxnflds,mfiles)) + ierr = pio_inq_varid(File, 'mdims', vdesc) + ierr = pio_get_var(File, vdesc, allmdims) + + !! mdim names + ! Read the hist coord names to make sure they are all registered + ierr = pio_inq_varid(File, 'mdimnames', vdesc) + call cam_pio_var_info(File, vdesc, ndims, dimids, dimlens) + mdimcnt = dimlens(2) + allocate(mdimnames(mdimcnt)) + ierr = pio_get_var(File, vdesc, mdimnames) + do f = 1, mdimcnt + ! Check to see if the mdim is registered + if (get_hist_coord_index(trim(mdimnames(fld_idx))) <= 0) then + ! We need to register this mdim (hist_coord) + call add_hist_coord(trim(mdimnames(fld_idx))) + end if + end do + + regen_hist_file(:) = .false. + + allocate(history_file(mfiles)) + + file => history_file + + do t = 1, mfiles + + if(regen_hist_int(fil_idx) == 1) then + regen_hist_file(fil_idx) = .true. + end if + + call strip_null(cpath(fil_idx)) + call strip_null(hrestpath(fil_idx)) + allocate(file(fil_idx)%hlist(nflds(fil_idx))) + + do f = 1,nflds(fil_idx) + + allocate(gridsonfile(cam_grid_num_grids() + 1, pfiles)) + gridsonfile = -1 + do t = 1, pfiles + do f = 1, nflds(fil_idx) + call set_field_dimensions(file(fil_idx)%hlist(fld_idx)%field) + + begdim1 = file(fil_idx)%hlist(fld_idx)%field%begdim1 + enddim1 = file(fil_idx)%hlist(fld_idx)%field%enddim1 + begdim2 = file(fil_idx)%hlist(fld_idx)%field%begdim2 + enddim2 = file(fil_idx)%hlist(fld_idx)%field%enddim2 + begdim3 = file(fil_idx)%hlist(fld_idx)%field%begdim3 + enddim3 = file(fil_idx)%hlist(fld_idx)%field%enddim3 + + allocate(file(fil_idx)%hlist(fld_idx)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3)) + if (file(fil_idx)%hlist(fld_idx)%avgflag .eq. 'S') then ! allocate the variance buffer for standard dev + allocate(file(fil_idx)%hlist(fld_idx)%sbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3)) + endif + + if (associated(file(fil_idx)%hlist(fld_idx)%varid)) then + deallocate(file(fil_idx)%hlist(fld_idx)%varid) + end if + nullify(file(fil_idx)%hlist(fld_idx)%varid) + if (associated(file(fil_idx)%hlist(fld_idx)%nacs)) then + deallocate(file(fil_idx)%hlist(fld_idx)%nacs) + end if + nullify(file(fil_idx)%hlist(fld_idx)%nacs) + if(file(fil_idx)%hlist(fld_idx)%field%flag_xyfill .or. (avgflag_perfile(fil_idx) == 'L')) then + allocate (file(fil_idx)%hlist(fld_idx)%nacs(begdim1:enddim1,begdim3:enddim3)) + else + allocate(file(fil_idx)%hlist(fld_idx)%nacs(1,begdim3:enddim3)) + end if + ! initialize all buffers to zero - this will be overwritten later by the + ! data in the history restart file if it exists. + call h_zero(f,t) + + ! Make sure this field's decomp is listed on the file + fdecomp = file(fil_idx)%hlist(fld_idx)%field%decomp_type + do ff = 1, size(gridsonfile, 1) + if (fdecomp == gridsonfile(ff, t)) then + exit + else if (gridsonfile(ff, t) < 0) then + gridsonfile(ff, t) = fdecomp + exit + end if + end do + + end do + end do + ! + !----------------------------------------------------------------------- + ! Read history restart files + !----------------------------------------------------------------------- + ! + ! Loop over the total number of history files declared and + ! read the pathname for any history restart files + ! that are present (if any). Test to see if the run is a restart run + ! AND if any history buffer regen files exist (regen_hist_file = .T.). + ! NOTE: regen_hist_file is preset to false, reset to true earlier in + ! this routine if hbuf restart files are written and saved in the + ! master restart file. Each history buffer restart file is then read. + ! NOTE: some f90 compilers (e.g. SGI) complain about I/O of + ! derived types which have pointer components, so explicitly read + ! each one. + ! + do t = 1, mfiles + if (regen_hist_file(fil_idx)) then + ! + ! Open history restart file + ! + call getfil (hrestpath(fil_idx), locfn) + call cam_pio_openfile(file(fil_idx)%File, locfn, 0) + ! + ! Read history restart file + ! + do f = 1, nflds(fil_idx) + + fname_tmp = strip_suffix(file(fil_idx)%hlist(fld_idx)%field%name) + if(masterproc) write(iulog, *) 'Reading history variable ',fname_tmp + ierr = pio_inq_varid(file(fil_idx)%File, fname_tmp, vdesc) + + call cam_pio_var_info(file(fil_idx)%File, vdesc, ndims, dimids, dimlens) + if(.not. associated(file(fil_idx)%hlist(fld_idx)%field%mdims)) then + dimcnt = 0 + do i = 1,ndims + ierr = pio_inq_dimname(file(fil_idx)%File, dimids(i), dname_tmp) + dimid = get_hist_coord_index(dname_tmp) + if(dimid >= 1) then + dimcnt = dimcnt + 1 + tmpdims(dimcnt) = dimid + ! No else, just looking for mdims (grid dims won't be hist coords) + end if + end do + if(dimcnt > 0) then + allocate(file(fil_idx)%hlist(fld_idx)%field%mdims(dimcnt)) + file(fil_idx)%hlist(fld_idx)%field%mdims(:) = tmpdims(1:dimcnt) + if(dimcnt > maxvarmdims) maxvarmdims = dimcnt + end if + end if + call set_field_dimensions(file(fil_idx)%hlist(fld_idx)%field) + begdim1 = file(fil_idx)%hlist(fld_idx)%field%begdim1 + enddim1 = file(fil_idx)%hlist(fld_idx)%field%enddim1 + fdims(1) = enddim1 - begdim1 + 1 + begdim2 = file(fil_idx)%hlist(fld_idx)%field%begdim2 + enddim2 = file(fil_idx)%hlist(fld_idx)%field%enddim2 + fdims(2) = enddim2 - begdim2 + 1 + begdim3 = file(fil_idx)%hlist(fld_idx)%field%begdim3 + enddim3 = file(fil_idx)%hlist(fld_idx)%field%enddim3 + fdims(3) = enddim3 - begdim3 + 1 + if (fdims(2) > 1) then + nfdims = 3 + else + nfdims = 2 + fdims(2) = fdims(3) + end if + fdecomp = file(fil_idx)%hlist(fld_idx)%field%decomp_type + if (nfdims > 2) then + call cam_grid_read_dist_array(file(fil_idx)%File, fdecomp, & + fdims(1:nfdims), dimlens(1:ndims), file(fil_idx)%hlist(fld_idx)%hbuf, vdesc) + else + call cam_grid_read_dist_array(file(fil_idx)%File, fdecomp, & + fdims(1:nfdims), dimlens(1:ndims), file(fil_idx)%hlist(fld_idx)%hbuf(:,1,:), vdesc) + end if + + if ( associated(file(fil_idx)%hlist(fld_idx)%sbuf) ) then + ! read in variance for standard deviation + ierr = pio_inq_varid(file(fil_idx)%File, trim(fname_tmp)//'_var', vdesc) + if (nfdims > 2) then + call cam_grid_read_dist_array(file(fil_idx)%File, fdecomp, & + fdims(1:nfdims), dimlens(1:ndims), file(fil_idx)%hlist(fld_idx)%sbuf, vdesc) + else + call cam_grid_read_dist_array(file(fil_idx)%File, fdecomp, & + fdims(1:nfdims), dimlens(1:ndims), file(fil_idx)%hlist(fld_idx)%sbuf(:,1,:), vdesc) + end if + endif + + ierr = pio_inq_varid(file(fil_idx)%File, trim(fname_tmp)//'_nacs', vdesc) + call cam_pio_var_info(file(fil_idx)%File, vdesc, nacsdimcnt, dimids, dimlens) + + if(nacsdimcnt > 0) then + if (nfdims > 2) then + ! nacs only has 2 dims (no levels) + fdims(2) = fdims(3) + end if + allocate(file(fil_idx)%hlist(fld_idx)%nacs(begdim1:enddim1,begdim3:enddim3)) + nacs => file(fil_idx)%hlist(fld_idx)%nacs(:,:) + call cam_grid_read_dist_array(file(fil_idx)%File, fdecomp, fdims(1:2), & + dimlens(1:nacsdimcnt), nacs, vdesc) + else + allocate(file(fil_idx)%hlist(fld_idx)%nacs(1,begdim3:enddim3)) + ierr = pio_get_var(file(fil_idx)%File, vdesc, nacsval) + file(fil_idx)%hlist(fld_idx)%nacs(1,:) = nacsval + end if + + end do + ! + ! Done reading this history restart file + ! + call cam_pio_closefile(file(fil_idx)%File) + + end if ! regen_hist_file(fil_idx) + + ! (re)create the master list of grid IDs + ff = 0 + do f = 1, size(gridsonfile, 1) + if (gridsonfile(f, t) > 0) then + ff = ff + 1 + end if + end do + allocate(file(fil_idx)%grid_ids(ff)) + ff = 1 + do f = 1, size(gridsonfile, 1) + if (gridsonfile(f, t) > 0) then + file(fil_idx)%grid_ids(ff) = gridsonfile(f, t) + ff = ff + 1 + end if + end do + call patch_init(fil_idx) + end do ! end of do mfiles loop + + ! + ! If the history files are partially complete (contain less than + ! mfilt(fil_idx) time samples, then get the files and open them.) + ! + ! NOTE: No need to perform this operation for IC history files or empty files + ! + + do t = 1,mfiles + if (is_initfile(file_index = t)) then + ! Initialize filename specifier for IC file + hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // '.i.%y-%m-%d-%s.nc' + nfils(fil_idx) = 0 + else if (nflds(fil_idx) == 0) then + nfils(fil_idx) = 0 + else + if (nfils(fil_idx) > 0) then + call getfil (cpath(fil_idx), locfn) + call cam_pio_openfile(file(fil_idx)%File, locfn, PIO_WRITE) + call h_inquire (fil_idx) + if(is_satfile(fil_idx)) then + ! Initialize the sat following history subsystem + call sat_hist_init() + call sat_hist_define(file(fil_idx)%File) + end if + end if + ! + ! If the history file is full, close the current unit + ! + if (nfils(fil_idx) >= mfilt(fil_idx)) then + if (masterproc) then + write(iulog,*)'READ_RESTART_HISTORY: nf_close(',t,') = ',nhfil(fil_idx), mfilt(fil_idx) + end if + do f = 1,nflds(fil_idx) + deallocate(file(fil_idx)%hlist(fld_idx)%varid) + nullify(file(fil_idx)%hlist(fld_idx)%varid) + end do + call cam_pio_closefile(file(fil_idx)%File) + nfils(fil_idx) = 0 + end if + end if + end do + + ! Setup vector pairs for unstructured grid interpolation + call setup_interpolation_and_define_vector_complements() + + if(mfiles /= pfiles .and. masterproc) then + write(iulog,*) ' WARNING: Restart file pfiles setting ',mfiles,' not equal to model setting ',pfiles + end if + + return + end subroutine read_restart_history + + !####################################################################### + + recursive function get_entry_by_name(listentry, name) result(entry) + type(master_entry), pointer :: listentry + character(len=*), intent(in) :: name ! variable name + type(master_entry), pointer :: entry + + if(associated(listentry)) then + if(listentry%field%name .eq. name) then + entry => listentry + else + entry =>get_entry_by_name(listentry%next_entry, name) + end if + else + nullify(entry) + end if + end function get_entry_by_name + + !####################################################################### + + subroutine AvgflagToString(avgflag, time_op) + ! Dummy arguments + character(len=1), intent(in) :: avgflag ! averaging flag + character(len=max_chars), intent(out) :: time_op ! time op (e.g. max) + + ! Local variable + character(len=*), parameter :: subname = 'AvgflagToString' + + select case (avgflag) + case ('A') + time_op(:) = 'mean' + case ('B') + time_op(:) = 'mean00z' + case ('I') + time_op(:) = ' ' + case ('X') + time_op(:) = 'maximum' + case ('M') + time_op(:) = 'minimum' + case('L') + time_op(:) = LT_DESC + case ('S') + time_op(:) = 'standard_deviation' + case default + call endrun(subname//': unknown avgflag = '//avgflag) + end select + end subroutine AvgflagToString + + !####################################################################### + + subroutine create_field_list() + + use cam_grid_support, only: cam_grid_num_grids + use spmd_utils, only: mpicom + use dycore, only: dycore_is + + !----------------------------------------------------------------------- + ! + ! Purpose: Define the contents of each history file based on namelist + ! input for initial or branch run, and restart data if a + ! restart run. + ! + ! Method: Use arrays fincl and fexcl to modify default history file + ! contents. + ! Then sort the result alphanumerically for later use by OUTFLD to + ! allow an n log n search time. + ! + !---------------------------Local variables----------------------------- + ! + integer fil_idx ! file index + integer fld_idx ! field index + integer ff ! index into include, exclude and fprec list + integer :: i + ! name: field name portion of fincl (i.e. no avgflag separator) + character(len=fieldname_len) :: name + ! mastername: name from masterlist field + character(len=max_fieldname_len) :: mastername + character(len=max_chars) :: errormsg ! error output field + character(len=1) :: avgflag ! averaging flag + character(len=1) :: prec_wrt ! history buffer write precision flag + + type (hentry) :: tmp ! temporary used for swapping + + type(master_entry), pointer :: listentry + logical :: fieldonfile ! .true. iff field on file + integer :: errors_found + + ! List of active grids (first dim) for each file (second dim) + ! An active grid is one for which there is a least one field being output + ! on that grid. + integer, allocatable :: gridsonfile(:,:) + ! The following list of field names are only valid for the FV dycore. + ! They appear in fincl settings of WACCM use case files which are + ! not restricted to the FV dycore. + ! To avoid duplicating long fincl lists in use case files to provide + ! both FV and non-FV versions this short list of fields is checked + ! for and removed from fincl lists when the dycore is not FV. + integer, parameter :: n_fv_only = 10 + character(len=6) :: fv_only_flds(n_fv_only) = & + [ 'VTHzm ', 'WTHzm ', 'UVzm ', 'UWzm ', 'Uzm ', & + 'Vzm ', 'Wzm ', 'THzm ', 'TH ', 'MSKtem' ] + + integer :: n_vec_comp, add_fincl_idx + integer, parameter :: nvecmax = 50 ! max number of vector components in a fincl list + character(len=2) :: avg_suffix + character(len=max_fieldname_len) :: vec_comp_names(nvecmax) + character(len=1) :: vec_comp_avgflag(nvecmax) + character(len=*), parameter :: subname = 'create_field_list' + !-------------------------------------------------------------------------- + + ! First ensure contents of fincl, fexcl, and fout_prec are all valid names + ! + errors_found = 0 + do fil_idx = 1, pfiles + + n_vec_comp = 0 + vec_comp_names = ' ' + vec_comp_avgflag = ' ' + do fld_idx = 1, pflds + if (len_trim(fincl(fld_idx, fil_idx)) == 0) then + exit ! No more fields on this file + else + add_fincl_idx = fld_idx ! Last used index + end if + name = getname(fincl(fld_idx, fil_idx)) + + if (.not. dycore_is('FV')) then + ! filter out fields only provided by FV dycore + fieldonfile = .false. + do i = 1, n_fv_only + if (name == fv_only_flds(i)) then + write(errormsg,'(4a,2(i0,a))') subname, ': ', & + trim(name), ' in fincl(', fil_idx, ', ', fld_idx, & + ') only available with FV dycore' + if (masterproc) then + write(iulog, *) trim(errormsg) + end if + fieldonfile = .true. + exit + end if + end do + if (fieldonfile) then + cycle ! We are excluding this FV-only field + end if + end if + + mastername = '' + listentry => get_entry_by_name(masterlinkedlist, name) + if (associated(listentry)) then + mastername = listentry%field%name + end if + if (name /= mastername) then + write(errormsg,'(4a,2(i0,a))') subname, ': ', trim(name), & + ' in fincl(', fld_idx, ', ', fil_idx, ') not found' + if (masterproc) then + write(iulog, *) trim(errormsg) + end if + errors_found = errors_found + 1 + else + if ( (len_trim(mastername) > 0) .and. & + interpolate_output(fil_idx)) then + if (n_vec_comp >= nvecmax) then + call endrun(subname//': need to increase nvecmax') + end if + ! If this is a vector component, save name of the complement + avgflag = getflag(fincl(fld_idx, fil_idx)) + if (len_trim(listentry%meridional_field) > 0) then + n_vec_comp = n_vec_comp + 1 + vec_comp_names(n_vec_comp) = listentry%meridional_field + vec_comp_avgflag(n_vec_comp) = avgflag + else if (len_trim(listentry%zonal_field) > 0) then + n_vec_comp = n_vec_comp + 1 + vec_comp_names(n_vec_comp) = listentry%zonal_field + vec_comp_avgflag(n_vec_comp) = avgflag + end if + end if + end if + end do + + ! Interpolation of vector components requires that both be present. + ! If the fincl specifier contains any vector components, then the + ! complement was saved in the array vec_comp_names. Next ensure + ! (for interpolated output only) that all complements + ! are also present in the fincl array. + ! The first empty slot in the current fincl array is index fld_idx + ! from loop above. + add_fincl_idx = add_fincl_idx + 1 + if ((add_fincl_idx > 1) .and. interpolate_output(fil_idx)) then + do i = 1, n_vec_comp + call list_index(fincl(:, fil_idx), vec_comp_names(i), ff) + if (ff == 0) then + + ! Add vector component to fincl. Don't need to check + ! whether its in the master list since this was done at + ! the time of registering the vector components. + avg_suffix = ' ' + if (len_trim(vec_comp_avgflag(i)) > 0) then + avg_suffix = ':' // vec_comp_avgflag(i) + end if + fincl(add_fincl_idx, fil_idx) = & + trim(vec_comp_names(i)) // avg_suffix + add_fincl_idx = add_fincl_idx + 1 + + write(errormsg,'(4a,i0,2a))') subname, ': ', & + trim(vec_comp_names(i)), ' added to fincl', fil_idx, & + '. Both vector components are required for ' & + 'interpolated output.' + if (masterproc) then + write(iulog,*) trim(errormsg) + end if + end if + end do + end if + + ! Check for non-existant excluded fields + fld_idx = 1 + do while ((fld_idx < pflds) .and. & + (len_trim(fexcl(fld_idx, fil_idx)) > ' ')) + mastername = '' + listentry => get_entry_by_name(masterlinkedlist, & + fexcl(fld_idx, fil_idx)) + if(associated(listentry)) then + mastername = listentry%field%name + end if + + if (fexcl(fld_idx, fil_idx) /= mastername) then + write(errormsg,'(4a,2(i0,a))') subname, ': ', & + trim(fexcl(fld_idx, fil_idx)), ' in fexcl(', fld_idx, & + ', ', fil_idx, ') not found' + if (masterproc) then + write(iulog,*) trim(errormsg) + end if + errors_found = errors_found + 1 + end if + fld_idx = fld_idx + 1 + end do + + fld_idx = 1 + do while ((fld_idx < pflds) .and. & + (len_trim(fout_prec(fld_idx,fil_idx)) > 0)) + name = getname(fout_prec(fld_idx,fil_idx)) + mastername = '' + listentry => get_entry_by_name(masterlinkedlist, name) + if(associated(listentry)) then + mastername = listentry%field%name + end if + if (name /= mastername) then + write(errormsg,'(4a,i0,a)') subname, ': ', trim(name), & + ' in fout_prec(', fld_idx, ') not found' + if (masterproc) then + write(iulog,*) trim(errormsg) + end if + errors_found = errors_found + 1 + end if + do ff = 1, fld_idx - 1 ! If duplicate entry is found, stop + if (trim(name) == trim(getname(fout_prec(ff,t)))) then + write(errormsg,'(4a)') subname, ': Duplicate field ', & + trim(name), ' in fout_prec' + if (masterproc) then + write(iulog,*) trim(errormsg) + end if + errors_found = errors_found + 1 + end if + end do + f = f + 1 + end do + end do + + if (errors_found > 0) then + ! Give masterproc a chance to write all the log messages + call mpi_barrier(mpicom, t) + write(errormsg, '(2a,i0,a)') subname, ': ',errors_found, & + ' errors found, see log' + call endrun(trim(errormsg)) + end if + + nflds(:) = 0 + ! IC history file is to be created, set properties + if(is_initfile()) then + hfilename_spec(pfiles) = '%c.cam' // trim(inst_suffix) // '.i.%y-%m-%d-%s.nc' + + ncprec(pfiles) = pio_double + ndens (pfiles) = 1 + mfilt (pfiles) = 1 + end if + + allocate(gridsonfile(cam_grid_num_grids() + 1, pfiles)) + gridsonfile = -1 + do fil_idx = 1, pfiles + ! + ! Add the field to the file if specified via namelist + ! (FINCL[1-pfiles]), or if it is on by default and was not + ! excluded via namelist (FEXCL[1-pfiles]). + ! Also set history buffer accumulation and output precision + ! values according to the values specified via namelist + ! (FWRTPR[1-pfiles] in namelist, FOUT_PREC) + ! or, if not on the list, to the default values given by + ! ndens(fil_idx). + ! + listentry => masterlinkedlist + do while(associated(listentry)) + mastername = listentry%field%name + call list_index (fincl(1,t), mastername, ff) + fieldonfile = .false. + if (ff > 0) then + fieldonfile = .true. + else if ((.not. empty_hfiles) .or. & + (is_initfile(file_index = t))) then + call list_index (fexcl(1,t), mastername, ff) + if ((ff == 0) .and. listentry%actflag(fil_idx)) then + fieldonfile = .true. + end if + end if + if (fieldonfile) then + ! The field is active so increment the number fo fields and add + ! its decomp type to the list of decomp types on this file + nflds(fil_idx) = nflds(fil_idx) + 1 + do ff = 1, size(gridsonfile, 1) + if (listentry%field%decomp_type == gridsonfile(ff, t)) then + exit + else if (gridsonfile(ff, t) < 0) then + gridsonfile(ff, t) = listentry%field%decomp_type + exit + end if + end do + end if + listentry => listentry%next_entry + end do + end do + ! + ! Determine total number of active history files + ! + if (masterproc) then + do fil_idx = 1, pfiles + if (nflds(fil_idx) == 0) then + write(iulog, '(2a,i0,a)') subname, ': File ', t, ' is empty' + end if + end do + endif + allocate(history_file(pfiles)) + file = >history_file + + + do fil_idx = 1, pfiles + nullify(file(fil_idx)%hlist) + ! Now we have a field count and can allocate + if(nflds(fil_idx) > 0) then + ! Allocate the correct number of hentry slots + allocate(file(fil_idx)%hlist(nflds(fil_idx))) + ! Count up the number of grids output on this file + ff = 0 + do f = 1, size(gridsonfile, 1) + if (gridsonfile(f, t) > 0) then + ff = ff + 1 + end if + end do + allocate(file(fil_idx)%grid_ids(ff)) + ff = 1 + do f = 1, size(gridsonfile, 1) + if (gridsonfile(f, t) > 0) then + file(fil_idx)%grid_ids(ff) = gridsonfile(f, t) + ff = ff + 1 + end if + end do + end if + do ff = 1,nflds(fil_idx) + nullify(file(fil_idx)%hlist(ff)%hbuf) + nullify(file(fil_idx)%hlist(ff)%sbuf) + nullify(file(fil_idx)%hlist(ff)%nacs) + nullify(file(fil_idx)%hlist(ff)%varid) + end do + + + nflds(fil_idx) = 0 ! recount to support array based method + listentry => masterlinkedlist + do while(associated(listentry)) + mastername = listentry%field%name + + call list_index (fout_prec(1,t), mastername, ff) + if (ff > 0) then + prec_wrt = getflag(fout_prec(ff,t)) + else + prec_wrt = ' ' + end if + + call list_index (fincl(1,t), mastername, ff) + + if (ff > 0) then + avgflag = getflag (fincl(ff,t)) + call inifld (t, listentry, avgflag, prec_wrt) + else if ((.not. empty_hfiles) .or. (is_initfile(file_index = t))) then + call list_index (fexcl(1,t), mastername, ff) + if (ff == 0 .and. listentry%actflag(fil_idx)) then + call inifld (t, listentry, ' ', prec_wrt) + else + listentry%actflag(fil_idx) = .false. + end if + else + listentry%actflag(fil_idx) = .false. + end if + listentry =>listentry%next_entry + + end do + ! + ! If column output is specified make sure there are some fields defined + ! for that file + ! + if (nflds(fil_idx) .eq. 0 .and. fincllonlat(1,t) .ne. ' ') then + write(errormsg,'(a,i2,a)') 'FLDLST: Column output is specified for file ',t,' but no fields defined for that file.' + call endrun(errormsg) + else + call patch_init(fil_idx) + end if + ! + ! Specification of file contents now complete. Sort each list of active + ! entries for efficiency in OUTFLD. Simple bubble sort. + ! + !!XXgoldyXX: v In the future, we will sort according to decomp to speed I/O + do f = nflds(fil_idx)-1,1,-1 + do ff = 1,f + + if (file(fil_idx)%hlist(ff)%field%name > file(fil_idx)%hlist(ff+1)%field%name) then + + tmp = file(fil_idx)%hlist(ff) + file(fil_idx)%hlist(ff ) = file(fil_idx)%hlist(ff+1) + file(fil_idx)%hlist(ff+1) = tmp + + else if (file(fil_idx)%hlist(ff )%field%name == file(fil_idx)%hlist(ff+1)%field%name) then + + write(errormsg,'(2a,2(a,i3))') 'FLDLST: Duplicate field: ', & + trim(file(fil_idx)%hlist(ff)%field%name),', file = ', t, ', ff = ', ff + call endrun(errormsg) + + end if + + end do + end do + + end do ! do fil_idx = 1, pfiles + deallocate(gridsonfile) + + call print_active_field_list() + + ! + ! Packing density, ndens: With netcdf, only 1 (nf_double) and 2 (pio_real) + ! are allowed + ! + do fil_idx = 1, pfiles + if (ndens(fil_idx) == 1) then + ncprec(fil_idx) = pio_double + else if (ndens(fil_idx) == 2) then + ncprec(fil_idx) = pio_real + else + call endrun ('FLDLST: ndens must be 1 or 2') + end if + + end do + ! Flush any waiting output + if (masterproc) then + call shr_sys_flush(iulog) + end if + + ! + ! Now that masterlinkedlist is defined, construct primary and + ! secondary hashing tables. + ! + call bld_outfld_hash_tbls() + call bld_hfilefld_indices() + + end subroutine create_field_list + + !########################################################################### + + subroutine print_active_field_list() + + integer :: f, ff, i, t + integer :: num_patches + + character(len=6) :: prec_str + character(len=max_chars) :: fldname, fname_tmp + + type(active_entry), pointer :: hfile(:) => null() ! history files + + character(len=*), parameter :: subname = 'print_active_field_list' + + if (masterproc) then + hfile => history_file + do fil_idx = 1, pfiles + if (nflds(fil_idx) > 0) then + write(iulog, *) ' ' + write(iulog, '(a,i2,a,i4,a)') 'FLDLST: History file ', & + fil_idx,' contains ', nflds(fil_idx), ' fields' + + if (is_initfile(file_index=fil_idx)) then + write(iulog, '(3a)') ' Write frequency: ', & + inithist,' (INITIAL CONDITIONS)' + else + if (nhtfrq(fil_idx) == 0) then + write(iulog, *) ' Write frequency: MONTHLY' + else + write(iulog, *) ' Write frequency: ', & + nhtfrq(fil_idx) + end if + end if + + write(iulog, *) ' Filename specifier: ', & + trim(hfilename_spec(fil_idx)) + + prec_str = 'double' + if (ndens(fil_idx) == 2) then + prec_str = 'single' + end if + write(iulog,*) ' Output precision: ', prec_str + write(iulog,*) ' Number of time samples per file: ', mfilt(fil_idx) + + ! grid info + if (associated(hfile(fil_idx)%patches)) then + write(iulog,*) ' Fields are represented on columns (FIELD_LON_LAT)' + else if (associated(hfile(fil_idx)%grid_ids)) then + write(iulog,*) ' Fields are represented on global grids:' + do i = 1, size(hfile(fil_idx)%grid_ids) + write(iulog,*) ' ', hfile(fil_idx)%grid_ids(i) + end do + else + call endrun(subname//': error in active_entry object') + end if + write(iulog,*)' Included fields are:' + end if + + do f = 1, nflds(fil_idx) + if (associated(hfile(fil_idx)%patches)) then + num_patches = size(hfile(fil_idx)%patches) + fldname = strip_suffix(hfile(fil_idx)%hlist(fld_idx)%field%name) + do i = 1, num_patches + ff = (f-1)*num_patches + i + fname_tmp = trim(fldname) + call hfile(fil_idx)%patches(i)%field_name(fname_tmp) + write(iulog, 9000) ff, fname_tmp, & + hfile(fil_idx)%hlist(fld_idx)%field%units, & + hfile(fil_idx)%hlist(fld_idx)%field%numlev, & + hfile(fil_idx)%hlist(fld_idx)%avgflag, & + trim(hfile(fil_idx)%hlist(fld_idx)%field%long_name) + end do + else + fldname = hfile(fil_idx)%hlist(fld_idx)%field%name + write(iulog,9000) f, fldname, & + hfile(fil_idx)%hlist(fld_idx)%field%units, & + hfile(fil_idx)%hlist(fld_idx)%field%numlev, & + hfile(fil_idx)%hlist(fld_idx)%avgflag, & + trim(hfile(fil_idx)%hlist(fld_idx)%field%long_name) + end if + end do + end do + end if + +9000 format(i5, 1x, a32, 1x, a16, 1x, i4, 1x, a1, 2x, 256a) + + end subroutine print_active_field_list + + !########################################################################### + + subroutine inifld (t, listentry, avgflag, prec_wrt) + use cam_grid_support, only: cam_grid_is_zonal + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the active list for a history file + ! + ! Method: Copy the data from the master field list to the active list for the file + ! Also: define mapping arrays from (col,chunk) -> (lon,lat) + ! + ! Author: CCM Core Group + ! + !----------------------------------------------------------------------- + + + ! + ! Arguments + ! + integer, intent(in) :: t ! history file index + + type(master_entry), pointer :: listentry + + character(len=1), intent(in) :: avgflag ! averaging flag + character(len=1), intent(in) :: prec_wrt ! history output precision flag + ! + ! Local workspace + ! + integer :: n ! field index on defined file + + + ! + ! Ensure that it is not to late to add a field to the history file + ! + if (hfiles_defined) then + call endrun ('INIFLD: Attempt to add field '//listentry%field%name//' after history files set') + end if + + nflds(fil_idx) = nflds(fil_idx) + 1 + n = nflds(fil_idx) + ! + ! Copy field info. + ! + if(n > size(file(fil_idx)%hlist)) then + write(iulog,*) 'file field miscount error ', n, size(file(fil_idx)%hlist) + call endrun() + end if + + file(fil_idx)%hlist(n)%field = listentry%field + + select case (prec_wrt) + case (' ') + if (ndens(fil_idx) == 1) then + file(fil_idx)%hlist(n)%hwrt_prec = 8 + else + file(fil_idx)%hlist(n)%hwrt_prec = 4 + end if + case ('4') + file(fil_idx)%hlist(n)%hwrt_prec = 4 + if (masterproc) then + write(iulog,*) 'INIFLD: Output data type for ', file(fil_idx)%hlist(n)%field%name, & + ' is real*4' + end if + case ('8') + file(fil_idx)%hlist(n)%hwrt_prec = 8 + if (masterproc) then + write(iulog,*) 'INIFLD: Output data type for ', file(fil_idx)%hlist(n)%field%name, & + ' is real*8' + end if + case default + call endrun ('INIFLD: unknown prec_wrt = '//prec_wrt) + end select + ! + ! Override the default averaging (masterlist) averaging flag if non-blank + ! + if (avgflag == ' ') then + file(fil_idx)%hlist(n)%avgflag = listentry%avgflag(fil_idx) + file(fil_idx)%hlist(n)%time_op = listentry%time_op(fil_idx) + else + file(fil_idx)%hlist(n)%avgflag = avgflag + call AvgflagToString(avgflag, file(fil_idx)%hlist(n)%time_op) + end if + + ! Some things can't be done with zonal fields + if (cam_grid_is_zonal(listentry%field%decomp_type)) then + if (file(fil_idx)%hlist(n)%avgflag == 'L') then + call endrun("Cannot perform local time processing on zonal data ("//trim(listentry%field%name)//")") + else if (is_satfile(fil_idx)) then + call endrun("Zonal data not valid for satellite history ("//trim(listentry%field%name)//")") + end if + end if + +#ifdef HDEBUG + if (masterproc) then + write(iulog,'(a,i0,3a,i0,a,i2)')'HDEBUG: ',__LINE__,' field ', & + trim(file(fil_idx)%hlist(n)%field%name), ' added as field number ', n, & + ' on file ', t + write(iulog,'(2a)')' units = ',trim(file(fil_idx)%hlist(n)%field%units) + write(iulog,'(a,i0)')' numlev = ',file(fil_idx)%hlist(n)%field%numlev + write(iulog,'(2a)')' avgflag = ',file(fil_idx)%hlist(n)%avgflag + write(iulog,'(3a)')' time_op = "',trim(file(fil_idx)%hlist(n)%time_op),'"' + write(iulog,'(a,i0)')' hwrt_prec = ',file(fil_idx)%hlist(n)%hwrt_prec + end if +#endif + + return + end subroutine inifld + + + subroutine patch_init(fil_idx) + use cam_history_support, only: history_patch_t + use cam_grid_support, only: cam_grid_compute_patch + + ! Dummy arguments + integer, intent(in) :: t ! Current file + + ! Local variables + integer :: ff ! Loop over fincllonlat entries + integer :: i ! General loop index + integer :: npatches + type(history_patch_t), pointer :: patchptr + + character(len=max_chars) :: errormsg + character(len=max_chars) :: lonlatname(pflds) + real(r8) :: beglon, beglat, endlon, endlat + + ! + ! Setup column information if this field will be written as group + ! First verify the column information in the namelist + ! Duplicates are an error, but we can just ignore them + ! + + ! I know, this shouldn't happen . . . yet: (better safe than sorry) + if (associated(file(fil_idx)%patches)) then + do i = 1, size(file(fil_idx)%patches) + call file(fil_idx)%patches(i)%deallocate() + end do + deallocate(file(fil_idx)%patches) + nullify(file(fil_idx)%patches) + end if + + ! First, count the number of patches and check for duplicates + ff = 1 ! Index of fincllonlat entry + npatches = 0 ! Number of unique patches in namelist entry + do while (len_trim(fincllonlat(ff, t)) > 0) + npatches = npatches + 1 + lonlatname(npatches) = trim(fincllonlat(ff, t)) + ! Check for duplicates + do i = 1, npatches - 1 + if (trim(lonlatname(i)) == trim(lonlatname(npatches))) then + write(errormsg, '(a,i0,3a)') 'Duplicate fincl', t, 'lonlat entry.', & + 'Duplicate entry is ', trim(lonlatname(i)) + write(iulog, *) 'patch_init: WARNING: '//errormsg + ! Remove the new entry + lonlatname(npatches) = '' + npatches = npatches - 1 + exit + end if + end do + ff = ff + 1 + end do + + ! Now we know how many patches, allocate space + if (npatches > 0) then + if (collect_column_output(fil_idx)) then + allocate(file(fil_idx)%patches(1)) + else + allocate(file(fil_idx)%patches(npatches)) + end if + + ! For each lat/lon specification, parse and create a patch for each grid + do ff = 1, npatches + if (collect_column_output(fil_idx)) then + ! For colleccted column output, we only have one patch + patchptr => file(fil_idx)%patches(1) + else + patchptr => file(fil_idx)%patches(ff) + patchptr%namelist_entry = trim(lonlatname(ff)) + end if + ! We need to set up one patch per (active) grid + patchptr%collected_output = collect_column_output(fil_idx) + call parseLonLat(lonlatname(ff), & + beglon, endlon, patchptr%lon_axis_name, & + beglat, endlat, patchptr%lat_axis_name) + if (associated(patchptr%patches)) then + ! One last sanity check + if (.not. collect_column_output(fil_idx)) then + write(errormsg, '(a,i0,2a)') 'Attempt to overwrite fincl', t, & + 'lonlat entry, ', trim(patchptr%namelist_entry) + call endrun('patch_init: '//errormsg) + end if + else + allocate(patchptr%patches(size(file(fil_idx)%grid_ids))) + end if + do i = 1, size(file(fil_idx)%grid_ids) + call cam_grid_compute_patch(file(fil_idx)%grid_ids(i), patchptr%patches(i),& + beglon, endlon, beglat, endlat, collect_column_output(fil_idx)) + end do + nullify(patchptr) + end do + end if + ! We are done processing this file's fincl#lonlat entries. Now, + ! compact each patch so that the output variables have no holes + ! We wait until now for when collect_column_output(fil_idx) is .true. since + ! all the fincl#lonlat entries are concatenated + if (associated(file(fil_idx)%patches)) then + do ff = 1, size(file(fil_idx)%patches) + call file(fil_idx)%patches(ff)%compact() + end do + end if + + end subroutine patch_init + + !####################################################################### + + subroutine strip_null(str) + character(len=*), intent(inout) :: str + integer :: i + do i = 1,len(str) + if(ichar(str(i:i)) == 0) str(i:i) = ' ' + end do + end subroutine strip_null + + character(len=max_fieldname_len) function strip_suffix (name) + ! + !---------------------------------------------------------- + ! + ! Purpose: Strip "&IC" suffix from fieldnames if it exists + ! + !---------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: name + ! + ! Local workspace + ! + integer :: n + ! + !----------------------------------------------------------------------- + ! + strip_suffix = ' ' + + do n = 1,fieldname_len + strip_suffix(n:n) = name(n:n) + if(name(n+1:n+1 ) == ' ' ) return + if(name(n+1:n+fieldname_suffix_len) == fieldname_suffix) return + end do + + strip_suffix(fieldname_len+1:max_fieldname_len) = name(fieldname_len+1:max_fieldname_len) + + return + + end function strip_suffix + + !####################################################################### + + character(len=fieldname_len) function getname (inname) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: retrieve name portion of inname + ! + ! Method: If an averaging flag separater character is present (":") in inname, + ! lop it off + ! + !------------------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: inname + ! + ! Local workspace + ! + integer :: length + integer :: i + + length = len (inname) + + if (length < fieldname_len .or. length > fieldname_lenp2) then + write(iulog,*) 'GETNAME: bad length = ',length + call endrun + end if + + getname = ' ' + do i = 1,fieldname_len + if (inname(i:i) == ':') exit + getname(i:i) = inname(i:i) + end do + + return + end function getname + + !####################################################################### + + ! parseRangeString: Parse either a coordinate descriptor (e.g., 10S) or a + ! coordinate range (e.g., 10e:20e) + ! chars represents the allowed coordinate character. + ! NB: Does not validate numerical values (e.g., lat <= 90) + subroutine parseRangeString(rangestr, chars, begval, begchar, begname, & + endval, endchar, endname) + + ! Dummy arguments + character(len=*), intent(in) :: rangestr + character(len=*), intent(in) :: chars + real(r8), intent(out) :: begval + character, intent(out) :: begchar + character(len=*), intent(out) :: begname + real(r8), intent(out) :: endval + character, intent(out) :: endchar + character(len=*), intent(out) :: endname + + ! Local variables + character(len=128) :: errormsg + integer :: colonpos + integer :: beglen, endlen + + ! First, see if we have a position or a range + colonpos = scan(rangestr, ':') + if (colonpos == 0) then + begname = trim(rangestr) + beglen = len_trim(begname) + endname = trim(begname) + else + beglen = colonpos - 1 + begname = rangestr(1:beglen) + endname = trim(rangestr(colonpos+1:)) + endlen = len_trim(endname) + end if + ! begname should be a number (integer or real) followed by a character + if (verify(begname, '0123456789.') /= beglen) then + write(errormsg, *) 'Coordinate range must begin with number, ', begname + call endrun('parseRangeString: '//errormsg) + end if + if (verify(begname(beglen:beglen), chars) /= 0) then + write(errormsg, *) 'Coordinate range must end with character in the ', & + 'set [', trim(chars), '] ', begname + call endrun('parseRangeString: '//errormsg) + end if + ! begname parses so collect the values + read(begname(1:beglen-1), *) begval + begchar = begname(beglen:beglen) + if (colonpos /= 0) then + ! endname should be a number (integer or real) followed by a character + if (verify(endname, '0123456789.') /= endlen) then + write(errormsg, *) 'Coordinate range must begin with number, ', endname + call endrun('parseRangeString: '//errormsg) + end if + if (verify(endname(endlen:endlen), chars) /= 0) then + write(errormsg, *) 'Coordinate range must end with character in the ',& + 'set [', trim(chars), '] ', endname + call endrun('parseRangeString: '//errormsg) + end if + ! endname parses so collect the values + read(endname(1:endlen-1), *) endval + endchar = endname(endlen:endlen) + else + endval = begval + endchar = begchar + end if + + end subroutine parseRangeString + + ! parseLonLat: Parse a lon_lat description allowed by the fincllonlat(n) + ! namelist entries. Returns the starting and ending values of + ! the point or range specified. + ! NB: Does not validate the range against any particular grid + subroutine parseLonLat(lonlatname, beglon, endlon, lonname, beglat, endlat, latname) + + ! Dummy arguments + character(len=*), intent(in) :: lonlatname + real(r8), intent(out) :: beglon + real(r8), intent(out) :: endlon + character(len=*), intent(out) :: lonname + real(r8), intent(out) :: beglat + real(r8), intent(out) :: endlat + character(len=*), intent(out) :: latname + + ! Local variables + character(len=128) :: errormsg + character(len=MAX_CHARS) :: lonstr, latstr + character(len=MAX_CHARS) :: begname, endname + character :: begchar, endchar + integer :: underpos + + ! + ! make sure _ separator is present + ! + underpos = scan(lonlatname, '_') + if (underpos == 0) then + write(errormsg,*) 'Improperly formatted fincllonlat string. ', & + 'Missing underscore character (xxxE_yyyS) ', lonlatname + call endrun('parseLonLat: '//errormsg) + end if + + ! Break out the longitude and latitude sections + lonstr = lonlatname(:underpos-1) + latstr = trim(lonlatname(underpos+1:)) + + ! Parse the longitude section + call parseRangeString(lonstr, 'eEwW', beglon, begchar, begname, endlon, endchar, endname) + ! Convert longitude to degrees East + if ((begchar == 'w') .or. (begchar == 'W')) then + if (beglon > 0.0_r8) then + beglon = 360._r8 - beglon + end if + end if + if ((beglon < 0._r8) .or. (beglon > 360._r8)) then + write(errormsg, *) 'Longitude specification out of range, ', trim(begname) + call endrun('parseLonLat: '//errormsg) + end if + if ((endchar == 'w') .or. (endchar == 'W')) then + if (endlon > 0.0_r8) then + endlon = 360._r8 - endlon + end if + end if + if ((endlon < 0._r8) .or. (endlon > 360._r8)) then + write(errormsg, *) 'Longitude specification out of range, ', trim(endname) + call endrun('parseLonLat: '//errormsg) + end if + if (beglon == endlon) then + lonname = trim(begname) + else + lonname = trim(begname)//'_to_'//trim(endname) + end if + + ! Parse the latitude section + call parseRangeString(latstr, 'nNsS', beglat, begchar, begname, endlat, endchar, endname) + ! Convert longitude to degrees East + if ((begchar == 's') .or. (begchar == 'S')) then + beglat = (-1._r8) * beglat + end if + if ((beglat < -90._r8) .or. (beglat > 90._r8)) then + write(errormsg, *) 'Latitude specification out of range, ', trim(begname) + call endrun('parseLonLat: '//errormsg) + end if + if ((endchar == 's') .or. (endchar == 'S')) then + endlat = (-1._r8) * endlat + end if + if ((endlat < -90._r8) .or. (endlat > 90._r8)) then + write(errormsg, *) 'Latitude specification out of range, ', trim(endname) + call endrun('parseLonLat: '//errormsg) + end if + if (beglat == endlat) then + latname = trim(begname) + else + latname = trim(begname)//'_to_'//trim(endname) + end if + + end subroutine parseLonLat + + + !####################################################################### + + character(len=1) function getflag (inname) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: retrieve flag portion of inname + ! + ! Method: If an averaging flag separater character is present (":") in inname, + ! return the character after it as the flag + ! + !------------------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: inname ! character string + ! + ! Local workspace + ! + integer :: length ! length of inname + integer :: i ! loop index + + length = len(inname) + + if (length /= fieldname_lenp2) then + write(iulog,*) 'GETFLAG: bad length = ',length + call endrun + end if + + getflag = ' ' + do i = 1,fieldname_lenp2-1 + if (inname(i:i) == ':') then + getflag = inname(i+1:i+1) + exit + end if + end do + + return + end function getflag + + !####################################################################### + + subroutine list_index (list, name, index) + ! + ! Input arguments + ! + character(len=*), intent(in) :: list(pflds) ! input list of names, possibly ":" delimited + character(len=max_fieldname_len), intent(in) :: name ! name to be searched for + ! + ! Output arguments + ! + integer, intent(out) :: index ! index of "name" in "list" + ! + ! Local workspace + ! + character(len=fieldname_len) :: listname ! input name with ":" stripped off. + integer f ! field index + + index = 0 + do f=1,pflds + ! + ! Only list items + ! + listname = getname (list(fld_idx)) + if (listname == ' ') exit + if (listname == name) then + index = f + exit + end if + end do + + return + end subroutine list_index + + !####################################################################### + + recursive subroutine outfld (fname, field, idim, c, avg_subcol_field) + use cam_history_buffers, only: hbuf_accum_inst, hbuf_accum_add, hbuf_accum_variance, & + hbuf_accum_add00z, hbuf_accum_max, hbuf_accum_min, & + hbuf_accum_addlcltime + use cam_history_support, only: dim_index_2d + use subcol_pack_mod, only: subcol_unpack + use cam_grid_support, only: cam_grid_id + + interface + subroutine subcol_field_avg_handler(idim, field_in, c, field_out) + use shr_kind_mod, only: r8 => shr_kind_r8 + integer, intent(in) :: idim + real(r8), intent(in) :: field_in(idim, *) + integer, intent(in) :: c + real(r8), intent(out) :: field_out(:,:) + end subroutine subcol_field_avg_handler + end interface + + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Accumulate (or take min, max, etc. as appropriate) input field + ! into its history buffer for appropriate files + ! + ! Method: Check 'masterlist' whether the requested field 'fname' is active + ! on one or more history files, and if so do the accumulation. + ! If not found, return silently. + ! subcol_field_avg_handler: + ! An interface into subcol_field_avg without creating a dependency as + ! this would cause a dependency loop. See subcol.F90 + ! Note: We cannot know a priori if field is a grid average field or a subcolumn + ! field because many fields passed to outfld are defined on ncol rather + ! than pcols or psetcols. Therefore, we use the avg_subcol_field input + ! to determine whether to average the field input before accumulation. + ! NB: If output is on a subcolumn grid (requested in addfle), it is + ! an error to use avg_subcol_field. A subcolumn field is assumed and + ! subcol_unpack is called before accumulation. + ! + ! Author: CCM Core Group + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: fname ! Field name--should be 8 chars long + + ! For structured grids, idim is the local longitude dimension. + ! For unstructured grids, idim is the local column dimension + ! For phys_decomp, it should be pcols or pcols*psubcols + integer, intent(in) :: idim + real(r8), intent(in) :: field(idim,*) ! Array containing field values + integer, intent(in) :: c ! chunk (physics) or latitude (dynamics) index + logical, optional, intent(in) :: avg_subcol_field + ! + ! Local variables + ! + integer :: t, f ! file, field indices + + character*1 :: avgflag ! averaging flag + + type (active_entry), pointer :: ofile(:) ! Local history_file pointer + real(r8),pointer :: hbuf(:,:) ! history buffer + real(r8),pointer :: sbuf(:,:) ! variance buffer + integer, pointer :: nacs(:) ! accumulation counter + integer :: begdim2, enddim2, endi + integer :: phys_decomp + type (dim_index_2d) :: dimind ! 2-D dimension index + logical :: flag_xyfill ! non-applicable xy points flagged with fillvalue + real(r8) :: fillvalue + real(r8), allocatable :: afield(:,:) ! Averaged field values + real(r8), allocatable :: ufield(:,:,:) ! Unpacked field values + integer :: ff ! masterlist index pointer + integer :: i, j + logical :: found + logical :: avg_subcols ! average subcols before accum + !----------------------------------------------------------------------- + + call get_field_properties(fname, found, file_out=ofile, ff_out=ff) + phys_decomp = cam_grid_id('physgrid') + + ! If this field is not active, return now + if (.not. found) then + return + end if + + ! + ! Note, the field may be on any or all of the history files (primary + ! and auxiliary). + ! + ! write(iulog,*)'fname_loc=',fname_loc + do t = 1, pfiles + if ( .not. masterlist(ff)%thisentry%actflag(fil_idx)) cycle + f = masterlist(ff)%thisentry%hfileindx(fil_idx) + ! + ! Update history buffer + ! + flag_xyfill = ofile(fil_idx)%hlist(fld_idx)%field%flag_xyfill + fillvalue = ofile(fil_idx)%hlist(fld_idx)%field%fillvalue + avgflag = ofile(fil_idx)%hlist(fld_idx)%avgflag + nacs => ofile(fil_idx)%hlist(fld_idx)%nacs(:,c) + hbuf => ofile(fil_idx)%hlist(fld_idx)%hbuf(:,:,c) + if (associated(file(fil_idx)%hlist(fld_idx)%sbuf)) then + sbuf => ofile(fil_idx)%hlist(fld_idx)%sbuf(:,:,c) + endif + dimind = ofile(fil_idx)%hlist(fld_idx)%field%get_dims(c) + + ! See notes above about validity of avg_subcol_field + if (ofile(fil_idx)%hlist(fld_idx)%field%is_subcol) then + if (present(avg_subcol_field)) then + call endrun('OUTFLD: Cannot average '//trim(fname)//', subcolumn output was requested in addfld') + end if + avg_subcols = .false. + else if (ofile(fil_idx)%hlist(fld_idx)%field%decomp_type == phys_decomp) then + if (present(avg_subcol_field)) then + avg_subcols = avg_subcol_field + else + avg_subcols = .false. + end if + else ! Any dynamics decomposition + if (present(avg_subcol_field)) then + call endrun('OUTFLD: avg_subcol_field only valid for physgrid') + else + avg_subcols = .false. + end if + end if + + begdim2 = ofile(fil_idx)%hlist(fld_idx)%field%begdim2 + enddim2 = ofile(fil_idx)%hlist(fld_idx)%field%enddim2 + if (avg_subcols) then + allocate(afield(pcols, begdim2:enddim2)) + call subcol_field_avg_handler(idim, field, c, afield) + ! Hack! Avoid duplicating select statement below + call outfld(fname, afield, pcols, c) + deallocate(afield) + else if (ofile(fil_idx)%hlist(fld_idx)%field%is_subcol) then + ! We have to assume that using mdimnames (e.g., psubcols) is + ! incompatible with the begdimx, enddimx usage (checked in addfld) + ! Since psubcols is included in levels, take that out + endi = (enddim2 - begdim2 + 1) / psubcols + allocate(ufield(pcols, psubcols, endi)) + allocate(afield(pcols*psubcols, endi)) + do j = 1, endi + do i = 1, idim + afield(i, j) = field(i, j) + end do + end do + ! Initialize unused aray locations. + if (idim < pcols*psubcols) then + if (flag_xyfill) then + afield(idim+1:pcols*psubcols, :) = fillvalue + else + afield(idim+1:pcols*psubcols, :) = 0.0_r8 + end if + end if + if (flag_xyfill) then + call subcol_unpack(c, afield, ufield, fillvalue) + else + call subcol_unpack(c, afield, ufield) + end if + deallocate(afield) + select case (avgflag) + + case ('I') ! Instantaneous + call hbuf_accum_inst(hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue) + + case ('A') ! Time average + call hbuf_accum_add(hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue) + + case ('B') ! Time average only 00z values + call hbuf_accum_add00z(hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue) + + case ('X') ! Maximum over time + call hbuf_accum_max (hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue) + + case ('M') ! Minimum over time + call hbuf_accum_min(hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue) + + case ('L') + call hbuf_accum_addlcltime(hbuf, ufield, nacs, dimind, pcols, & + flag_xyfill, fillvalue, c, & + ofile(fil_idx)%hlist(fld_idx)%field%decomp_type, & + lcltod_start(fil_idx), lcltod_stop(fil_idx)) + + case ('S') ! Standard deviation + call hbuf_accum_variance(hbuf, sbuf, ufield, nacs, dimind, pcols,& + flag_xyfill, fillvalue) + + case default + call endrun ('OUTFLD: invalid avgflag='//avgflag) + + end select + deallocate(ufield) + else + select case (avgflag) + + case ('I') ! Instantaneous + call hbuf_accum_inst(hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue) + + case ('A') ! Time average + call hbuf_accum_add(hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue) + + case ('B') ! Time average only 00z values + call hbuf_accum_add00z(hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue) + + case ('X') ! Maximum over time + call hbuf_accum_max (hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue) + + case ('M') ! Minimum over time + call hbuf_accum_min(hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue) + + case ('L') + call hbuf_accum_addlcltime(hbuf, field, nacs, dimind, idim, & + flag_xyfill, fillvalue, c, & + ofile(fil_idx)%hlist(fld_idx)%field%decomp_type, & + lcltod_start(fil_idx), lcltod_stop(fil_idx)) + + case ('S') ! Standard deviation + call hbuf_accum_variance(hbuf, sbuf, field, nacs, dimind, idim,& + flag_xyfill, fillvalue) + + case default + call endrun ('OUTFLD: invalid avgflag='//avgflag) + + end select + end if + + end do + + return + end subroutine outfld + + !####################################################################### + + subroutine get_field_properties(fname, found, file_out, ff_out, no_file_check_in) + + implicit none + ! + !----------------------------------------------------------------------- + ! + ! Purpose: If fname is active, lookup and return field information + ! + ! Method: Check 'masterlist' whether the requested field 'fname' is active + ! on one or more history files, and if so, return the requested + ! field information + ! + ! Author: goldy + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: fname ! Field name--should be 8 chars long + logical, intent(out) :: found ! Set to true if fname is active + type(active_entry), pointer, optional :: file_out(:) + integer, intent(out), optional :: ff_out + logical, intent(in), optional :: no_file_check_in + + ! + ! Local variables + ! + character*(max_fieldname_len) :: fname_loc ! max-char equivalent of fname + integer :: t, ff ! file, masterindex indices + logical :: no_file_check + !----------------------------------------------------------------------- + + ! Need to re-cast the field name so that the hashing works #hackalert + fname_loc = fname + ff = get_masterlist_indx(fname_loc) + + ! Set the no_file_check to false, unless is passed in + if (present(no_file_check_in)) then + no_file_check = no_file_check_in + else + no_file_check = .false. + end if + + ! Set found to .false. so we can return early if fname is not active + found = .false. + if (present(file_out)) then + nullify(file_out) + end if + if (present(ff_out)) then + ff_out = -1 + end if + + ! + ! If ( ff < 0 ), the field is not defined on the masterlist. This check + ! is necessary because of coding errors calling outfld without first defining + ! the field on masterlist. + ! + if ( ff < 0 ) then + return + end if + ! + ! Next, check to see whether this field is active on one or more history + ! files. + ! + if (no_file_check) then + if (present(ff_out)) ff_out = ff ! Set the output index and return without checking files + return + else if ( .not. masterlist(ff)%thisentry%act_somefile ) then + return + end if + ! + ! Note, the field may be on any or all of the history files (primary + ! and auxiliary). + ! + + do t=1, pfiles + if (masterlist(ff)%thisentry%actflag(fil_idx)) then + found = .true. + if (present(file_out)) then + file_out => history_file + end if + if (present(ff_out)) then + ff_out = ff + end if + ! We found the info so we are done with the loop + exit + end if + end do + + end subroutine get_field_properties + + !####################################################################### + + logical function is_initfile(file_index) + ! + !------------------------------------------------------------------------ + ! + ! Purpose: to determine: + ! + ! a) if an IC file is active in this model run at all + ! OR, + ! b) if it is active, is the current file index referencing the IC file + ! (IC file is always at pfiles) + ! + !------------------------------------------------------------------------ + ! + ! Arguments + ! + integer, intent(in), optional :: file_index ! index of file in question + + is_initfile = .false. + + if (present(file_index)) then + if ((inithist /= 'NONE') .and. (file_index == pfiles)) then + is_initfile = .true. + end if + else + if (inithist /= 'NONE') then + is_initfile = .true. + end if + end if + + end function is_initfile + + !####################################################################### + + integer function strcmpf (name1, name2) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Return the lexical difference between two strings + ! + ! Method: Use ichar() intrinsic as we loop through the names + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=max_fieldname_len), intent(in) :: name1 ! string to compare + character(len=max_fieldname_len), intent(in) :: name2 ! string to compare + integer :: n ! loop index + + do n = 1, max_fieldname_len + strcmpf = ichar(name1(n:n)) - ichar(name2(n:n)) + if (strcmpf /= 0) then + exit + end if + end do + + end function strcmpf + + !####################################################################### + + subroutine h_inquire (fil_idx) + use pio, only: pio_inq_varid, pio_inq_attlen + use cam_pio_utils, only: cam_pio_handle_error + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Ensure that the proper variables are on a history file + ! + ! Method: Issue the appropriate netcdf wrapper calls + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + integer, intent(in) :: t ! file index + ! + ! Local workspace + ! + integer :: f ! field index + integer :: ierr + integer :: i + integer :: num_patches + integer(pio_offset_kind) :: mdimsize + character(len=max_chars) :: fldname, fname_tmp, basename + + ! + ! + ! Dimension id's + ! + file => history_file + + + + ! + ! Create variables for model timing and header information + ! + if(.not. is_satfile(fil_idx)) then + ierr=pio_inq_varid (file(fil_idx)%File,'ndcur ', file(fil_idx)%ndcurid) + ierr=pio_inq_varid (file(fil_idx)%File,'nscur ', file(fil_idx)%nscurid) + ierr=pio_inq_varid (file(fil_idx)%File,'nsteph ', file(fil_idx)%nstephid) + + ierr=pio_inq_varid (file(fil_idx)%File,'time_bnds', file(fil_idx)%tbndid) + ierr=pio_inq_varid (file(fil_idx)%File,'date_written',file(fil_idx)%date_writtenid) + ierr=pio_inq_varid (file(fil_idx)%File,'time_written',file(fil_idx)%time_writtenid) +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_inq_varid (file(fil_idx)%File,'tsec ',file(fil_idx)%tsecid) + ierr=pio_inq_varid (file(fil_idx)%File,'bdate ',file(fil_idx)%bdateid) +#endif + if (.not. is_initfile(file_index=t) ) then + ! Don't write the GHG/Solar forcing data to the IC file. It is never + ! read from that file so it's confusing to have it there. + ierr=pio_inq_varid (file(fil_idx)%File,'co2vmr ', file(fil_idx)%co2vmrid) + ierr=pio_inq_varid (file(fil_idx)%File,'ch4vmr ', file(fil_idx)%ch4vmrid) + ierr=pio_inq_varid (file(fil_idx)%File,'n2ovmr ', file(fil_idx)%n2ovmrid) + ierr=pio_inq_varid (file(fil_idx)%File,'f11vmr ', file(fil_idx)%f11vmrid) + ierr=pio_inq_varid (file(fil_idx)%File,'f12vmr ', file(fil_idx)%f12vmrid) + ierr=pio_inq_varid (file(fil_idx)%File,'sol_tsi ', file(fil_idx)%sol_tsiid) + if (solar_parms_on) then + ierr=pio_inq_varid (file(fil_idx)%File,'f107 ', file(fil_idx)%f107id) + ierr=pio_inq_varid (file(fil_idx)%File,'f107a ', file(fil_idx)%f107aid) + ierr=pio_inq_varid (file(fil_idx)%File,'f107p ', file(fil_idx)%f107pid) + ierr=pio_inq_varid (file(fil_idx)%File,'kp ', file(fil_idx)%kpid) + ierr=pio_inq_varid (file(fil_idx)%File,'ap ', file(fil_idx)%apid) + endif + if (solar_wind_on) then + ierr=pio_inq_varid (file(fil_idx)%File,'byimf', file(fil_idx)%byimfid) + ierr=pio_inq_varid (file(fil_idx)%File,'bzimf', file(fil_idx)%bzimfid) + ierr=pio_inq_varid (file(fil_idx)%File,'swvel', file(fil_idx)%swvelid) + ierr=pio_inq_varid (file(fil_idx)%File,'swden', file(fil_idx)%swdenid) + endif + if (epot_active) then + ierr=pio_inq_varid (file(fil_idx)%File,'colat_crit1', file(fil_idx)%colat_crit1_id) + ierr=pio_inq_varid (file(fil_idx)%File,'colat_crit2', file(fil_idx)%colat_crit2_id) + endif + end if + end if + ierr=pio_inq_varid (file(fil_idx)%File,'date ', file(fil_idx)%dateid) + ierr=pio_inq_varid (file(fil_idx)%File,'datesec ', file(fil_idx)%datesecid) + ierr=pio_inq_varid (file(fil_idx)%File,'time ', file(fil_idx)%timeid) + + + ! + ! Obtain variable name from ID which was read from restart file + ! + do f=1,nflds(fil_idx) + if(.not. associated(file(fil_idx)%hlist(fld_idx)%varid)) then + if (associated(file(fil_idx)%patches)) then + allocate(file(fil_idx)%hlist(fld_idx)%varid(size(file(fil_idx)%patches))) + else + allocate(file(fil_idx)%hlist(fld_idx)%varid(1)) + end if + end if + ! + ! If this field will be put out as columns then get column names for field + ! + if (associated(file(fil_idx)%patches)) then + num_patches = size(file(fil_idx)%patches) + fldname = strip_suffix(file(fil_idx)%hlist(fld_idx)%field%name) + do i = 1, num_patches + fname_tmp = trim(fldname) + call file(fil_idx)%patches(i)%field_name(fname_tmp) + ierr = pio_inq_varid(file(fil_idx)%File, trim(fname_tmp), file(fil_idx)%hlist(fld_idx)%varid(i)) + call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting ID for '//trim(fname_tmp)) + ierr = pio_get_att(file(fil_idx)%File, file(fil_idx)%hlist(fld_idx)%varid(i), 'basename', basename) + call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting basename for '//trim(fname_tmp)) + if (trim(fldname) /= trim(basename)) then + call endrun('H_INQUIRE: basename ('//trim(basename)//') does not match fldname ('//trim(fldname)//')') + end if + end do + else + fldname = file(fil_idx)%hlist(fld_idx)%field%name + ierr = pio_inq_varid(file(fil_idx)%File, trim(fldname), file(fil_idx)%hlist(fld_idx)%varid(1)) + call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting ID for '//trim(fldname)) + end if + if(file(fil_idx)%hlist(fld_idx)%field%numlev>1) then + ierr = pio_inq_attlen(file(fil_idx)%File,file(fil_idx)%hlist(fld_idx)%varid(1),'mdims', mdimsize) + if(.not. associated(file(fil_idx)%hlist(fld_idx)%field%mdims)) then + allocate(file(fil_idx)%hlist(fld_idx)%field%mdims(mdimsize)) + end if + ierr=pio_get_att(file(fil_idx)%File,file(fil_idx)%hlist(fld_idx)%varid(1),'mdims', & + file(fil_idx)%hlist(fld_idx)%field%mdims(1:mdimsize)) + if(mdimsize>maxvarmdims) maxvarmdims=mdimsize + end if + + end do + + if(masterproc) then + write(iulog,*)'H_INQUIRE: Successfully opened netcdf file ' + end if + + return + end subroutine h_inquire + + !####################################################################### + + subroutine add_default (name, tindex, flag) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the default "on" list for a given history file + ! + ! Method: + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: name ! field name + character(len=1), intent(in) :: flag ! averaging flag + + integer, intent(in) :: tindex ! history file index + ! + ! Local workspace + ! + integer :: t ! file index + type(master_entry), pointer :: listentry + + if (hfiles_defined) then + call endrun ('ADD_DEFAULT: Attempt to add hist default '//trim(name)//' after history files set') + end if + ! + ! Check validity of input arguments + ! + if (tindex > pfiles) then + write(iulog,*)'ADD_DEFAULT: file index=', tindex, ' is too big' + call endrun + end if + + ! Add to IC file if tindex = 0, reset to pfiles + if (tindex == 0) then + t = pfiles + if ( .not. is_initfile(file_index=t) ) return + else + t = tindex + end if + + if (verify(flag, HIST_AVG_FLAGS) /= 0) then + call endrun ('ADD_DEFAULT: unknown averaging flag='//flag) + end if + ! + ! Look through master list for input field name. When found, set active + ! flag for that file to true. Also set averaging flag if told to use other + ! than default. + ! + listentry => get_entry_by_name(masterlinkedlist, trim(name)) + if(.not.associated(listentry)) then + call endrun ('ADD_DEFAULT: field = "'//trim(name)//'" not found') + end if + listentry%actflag(fil_idx) = .true. + if (flag /= ' ') then + listentry%avgflag(fil_idx) = flag + call AvgflagToString(flag, listentry%time_op(fil_idx)) + end if + + return + end subroutine add_default + + !####################################################################### + + subroutine h_override (fil_idx) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Override default history file contents for a specific file + ! + ! Method: Copy the flag into the master field list + ! + !----------------------------------------------------------------------- + ! + ! Arguments + ! + integer, intent(in) :: t ! history file index + ! + ! Local workspace + ! + character(len=1) :: avgflg ! lcl equiv of avgflag_perfile(fil_idx) (to address xlf90 compiler bug) + + type(master_entry), pointer :: listentry + + + avgflg = avgflag_perfile(fil_idx) + + + listentry=>masterlinkedlist + do while(associated(listentry)) + call AvgflagToString(avgflg, listentry%time_op(fil_idx)) + listentry%avgflag(fil_idx) = avgflag_perfile(fil_idx) + listentry=>listentry%next_entry + end do + + end subroutine h_override + + !####################################################################### + + subroutine h_define (t, restart) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Define contents of history file t + ! + ! Method: Issue the required netcdf wrapper calls to define the history file contents + ! + !----------------------------------------------------------------------- + use cam_grid_support, only: cam_grid_header_info_t + use cam_grid_support, only: cam_grid_write_attr, cam_grid_write_var + use time_manager, only: get_step_size, get_ref_date, timemgr_get_calendar_cf + use cam_abortutils, only: endrun + use cam_pio_utils, only: vdesc_ptr, cam_pio_handle_error, cam_pio_def_dim + use cam_pio_utils, only: cam_pio_createfile, cam_pio_def_var + use sat_hist, only: sat_hist_define + + !----------------------------------------------------------------------- + + ! + ! Input arguments + ! + integer, intent(in) :: t ! file index + logical, intent(in) :: restart + ! + ! Local workspace + ! + integer :: i, j ! longitude, latitude indices + integer :: grd ! indices for looping through grids + integer :: f ! field index + integer :: ncreal ! real data type for output + integer :: dtime ! timestep size + integer :: sec_nhtfrq ! nhtfrq converted to seconds + integer :: ndbase = 0 ! days component of base time + integer :: nsbase = 0 ! seconds component of base time + integer :: nbdate ! base date in yyyymmdd format + integer :: nbsec ! time of day component of base date [seconds] + integer :: yr, mon, day ! year, month, day components of a date + + character(len=max_chars) :: str ! character temporary + character(len=max_chars) :: fname_tmp ! local copy of field name + character(len=max_chars) :: calendar ! Calendar type + character(len=max_chars) :: cell_methods ! For cell_methods attribute + character(len=16) :: time_per_freq + character(len=128) :: errormsg + + integer :: ret ! function return value + + ! + ! netcdf dimensions + ! + integer :: chardim ! character dimension id + integer :: dimenchar(2) ! character dimension ids + integer :: nacsdims(2) ! dimension ids for nacs (used in restart file) + integer :: bnddim ! bounds dimension id + integer :: timdim ! unlimited dimension id + + integer :: dimindex(8) ! dimension ids for variable declaration + integer :: dimids_tmp(8) ! dimension ids for variable declaration + + ! + ! netcdf variables + ! + ! A structure to hold the horizontal dimension and coordinate info + type(cam_grid_header_info_t), allocatable :: header_info(:) + ! For satellite files and column output + type(vdesc_ptr), allocatable :: latvar(:) ! latitude variable ids + type(vdesc_ptr), allocatable :: lonvar(:) ! longitude variable ids + + type(var_desc_t), pointer :: varid => NULL() ! temporary variable descriptor + integer :: num_hdims, fdims + integer :: num_patches ! How many entries for a field on this file? + integer, pointer :: mdims(:) => NULL() + integer :: mdimsize + integer :: ierr + integer, allocatable :: mdimids(:) + integer :: amode + logical :: interpolate + logical :: patch_output + + if(restart) then + file => restarthistory_files + if(masterproc) write(iulog,*)'Opening netcdf history restart file ', trim(hrestpath(fil_idx)) + else + file => history_file + if(masterproc) write(iulog,*)'Opening netcdf history file ', trim(nhfil(fil_idx)) + end if + + amode = PIO_CLOBBER + + if(restart) then + call cam_pio_createfile (file(fil_idx)%File, hrestpath(fil_idx), amode) + else + call cam_pio_createfile (file(fil_idx)%File, nhfil(fil_idx), amode) + end if + if(is_satfile(fil_idx)) then + interpolate = .false. ! !!XXgoldyXX: Do we ever want to support this? + patch_output = .false. + call cam_pio_def_dim(file(fil_idx)%File, 'ncol', pio_unlimited, timdim) + call cam_pio_def_dim(file(fil_idx)%File, 'nbnd', 2, bnddim) + + allocate(latvar(1), lonvar(1)) + allocate(latvar(1)%vd, lonvar(1)%vd) + call cam_pio_def_var(file(fil_idx)%File, 'lat', pio_double, (/timdim/), & + latvar(1)%vd) + ierr=pio_put_att (file(fil_idx)%File, latvar(1)%vd, 'long_name', 'latitude') + ierr=pio_put_att (file(fil_idx)%File, latvar(1)%vd, 'units', 'degrees_north') + + call cam_pio_def_var(file(fil_idx)%File, 'lon', pio_double, (/timdim/), & + lonvar(1)%vd) + ierr=pio_put_att (file(fil_idx)%File, lonvar(1)%vd,'long_name','longitude') + ierr=pio_put_att (file(fil_idx)%File, lonvar(1)%vd,'units','degrees_east') + + else + ! + ! Setup netcdf file - create the dimensions of lat,lon,time,level + ! + ! interpolate is only supported for unstructured dycores + interpolate = (interpolate_output(fil_idx) .and. (.not. restart)) + patch_output = (associated(file(fil_idx)%patches) .and. (.not. restart)) + + ! First define the horizontal grid dims + ! Interpolation is special in that we ignore the native grids + if(interpolate) then + allocate(header_info(1)) + call cam_grid_write_attr(file(fil_idx)%File, interpolate_info(fil_idx)%grid_id, header_info(1)) + else if (patch_output) then + ! We are doing patch (column) output + if (allocated(header_info)) then + ! We shouldn't have any header_info yet + call endrun('H_DEFINE: header_info should not be allocated for patch output') + end if + do i = 1, size(file(fil_idx)%patches) + call file(fil_idx)%patches(i)%write_attrs(file(fil_idx)%File) + end do + else + allocate(header_info(size(file(fil_idx)%grid_ids))) + do i = 1, size(file(fil_idx)%grid_ids) + call cam_grid_write_attr(file(fil_idx)%File, file(fil_idx)%grid_ids(i), header_info(i)) + end do + end if ! interpolate + + ! Define the unlimited time dim + call cam_pio_def_dim(file(fil_idx)%File, 'time', pio_unlimited, timdim) + call cam_pio_def_dim(file(fil_idx)%File, 'nbnd', 2, bnddim, existOK=.true.) + call cam_pio_def_dim(file(fil_idx)%File, 'chars', 8, chardim) + end if ! is satfile + + ! Populate the history coordinate (well, mdims anyway) attributes + ! This routine also allocates the mdimids array + call write_hist_coord_attrs(file(fil_idx)%File, bnddim, mdimids, restart) + + call get_ref_date(yr, mon, day, nbsec) + nbdate = yr*10000 + mon*100 + day + ierr=pio_def_var (file(fil_idx)%File,'time',pio_double,(/timdim/),file(fil_idx)%timeid) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%timeid, 'long_name', 'time') + str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%timeid, 'units', trim(str)) + + calendar = timemgr_get_calendar_cf() + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%timeid, 'calendar', trim(calendar)) + + + ierr=pio_def_var (file(fil_idx)%File,'date ',pio_int,(/timdim/),file(fil_idx)%dateid) + str = 'current date (YYYYMMDD)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%dateid, 'long_name', trim(str)) + + + ierr=pio_def_var (file(fil_idx)%File,'datesec ',pio_int,(/timdim/), file(fil_idx)%datesecid) + str = 'current seconds of current date' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%datesecid, 'long_name', trim(str)) + + ! + ! Character header information + ! + str = 'CF-1.0' + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'Conventions', trim(str)) + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'source', 'CAM') +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'CAM_GENERATED_FORCING','create SCAM IOP dataset') +#endif + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'case',caseid) + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'logname',logname) + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'host', host) + + ! Put these back in when they are filled properly + ! ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'title',ctitle) + ! ierr= pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'Version', & + ! '$Name$') + ! ierr= pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'revision_Id', & + ! '$Id$') + + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'initial_file', ncdata) + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'topography_file', bnd_topo) + if (len_trim(model_doi_url) > 0) then + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'model_doi_url', model_doi_url) + end if + + ! Determine what time period frequency is being output for each file + ! Note that nhtfrq is now in timesteps + + sec_nhtfrq = nhtfrq(fil_idx) + + ! If nhtfrq is in hours, convert to seconds + if (nhtfrq(fil_idx) < 0) then + sec_nhtfrq = abs(nhtfrq(fil_idx))*3600 + end if + + dtime = get_step_size() + if (sec_nhtfrq == 0) then !month + time_per_freq = 'month_1' + else if (mod(sec_nhtfrq*dtime,86400) == 0) then ! day + write(time_per_freq,999) 'day_',sec_nhtfrq*dtime/86400 + else if (mod(sec_nhtfrq*dtime,3600) == 0) then ! hour + write(time_per_freq,999) 'hour_',(sec_nhtfrq*dtime)/3600 + else if (mod(sec_nhtfrq*dtime,60) == 0) then ! minute + write(time_per_freq,999) 'minute_',(sec_nhtfrq*dtime)/60 + else ! second + write(time_per_freq,999) 'second_',sec_nhtfrq*dtime + end if +999 format(a,i0) + + ierr=pio_put_att (file(fil_idx)%File, PIO_GLOBAL, 'time_period_freq', trim(time_per_freq)) + + if(.not. is_satfile(fil_idx)) then + + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%timeid, 'bounds', 'time_bnds') + + ierr=pio_def_var (file(fil_idx)%File,'time_bnds',pio_double,(/bnddim,timdim/),file(fil_idx)%tbndid) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%tbndid, 'long_name', 'time interval endpoints') + ! + ! Character + ! + dimenchar(1) = chardim + dimenchar(2) = timdim + ierr=pio_def_var (file(fil_idx)%File,'date_written',PIO_CHAR,dimenchar, file(fil_idx)%date_writtenid) + ierr=pio_def_var (file(fil_idx)%File,'time_written',PIO_CHAR,dimenchar, file(fil_idx)%time_writtenid) + ! + ! Integer Header + ! + + ierr=pio_def_var (file(fil_idx)%File,'ndbase',PIO_INT,file(fil_idx)%ndbaseid) + str = 'base day' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%ndbaseid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'nsbase',PIO_INT,file(fil_idx)%nsbaseid) + str = 'seconds of base day' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%nsbaseid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'nbdate',PIO_INT,file(fil_idx)%nbdateid) + str = 'base date (YYYYMMDD)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%nbdateid, 'long_name', trim(str)) + +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_def_var (file(fil_idx)%File,'bdate',PIO_INT,file(fil_idx)%bdateid) + str = 'base date (YYYYMMDD)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%bdateid, 'long_name', trim(str)) +#endif + ierr=pio_def_var (file(fil_idx)%File,'nbsec',PIO_INT,file(fil_idx)%nbsecid) + str = 'seconds of base date' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%nbsecid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'mdt',PIO_INT,file(fil_idx)%mdtid) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%mdtid, 'long_name', 'timestep') + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%mdtid, 'units', 's') + + ! + ! Create variables for model timing and header information + ! + + ierr=pio_def_var (file(fil_idx)%File,'ndcur ',pio_int,(/timdim/),file(fil_idx)%ndcurid) + str = 'current day (from base day)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%ndcurid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'nscur ',pio_int,(/timdim/),file(fil_idx)%nscurid) + str = 'current seconds of current day' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%nscurid, 'long_name', trim(str)) + + + if (.not. is_initfile(file_index=t)) then + ! Don't write the GHG/Solar forcing data to the IC file. + ierr=pio_def_var (file(fil_idx)%File,'co2vmr ',pio_double,(/timdim/),file(fil_idx)%co2vmrid) + str = 'co2 volume mixing ratio' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%co2vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'ch4vmr ',pio_double,(/timdim/),file(fil_idx)%ch4vmrid) + str = 'ch4 volume mixing ratio' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%ch4vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'n2ovmr ',pio_double,(/timdim/),file(fil_idx)%n2ovmrid) + str = 'n2o volume mixing ratio' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%n2ovmrid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'f11vmr ',pio_double,(/timdim/),file(fil_idx)%f11vmrid) + str = 'f11 volume mixing ratio' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f11vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'f12vmr ',pio_double,(/timdim/),file(fil_idx)%f12vmrid) + str = 'f12 volume mixing ratio' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f12vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'sol_tsi ',pio_double,(/timdim/),file(fil_idx)%sol_tsiid) + str = 'total solar irradiance' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%sol_tsiid, 'long_name', trim(str)) + str = 'W/m2' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%sol_tsiid, 'units', trim(str)) + + if (solar_parms_on) then + ! solar / geomagetic activity indices... + ierr=pio_def_var (file(fil_idx)%File,'f107',pio_double,(/timdim/),file(fil_idx)%f107id) + str = '10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f107id, 'long_name', trim(str)) + str = '10^-22 W m^-2 Hz^-1' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f107id, 'units', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'f107a',pio_double,(/timdim/),file(fil_idx)%f107aid) + str = '81-day centered mean of 10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f107aid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'f107p',pio_double,(/timdim/),file(fil_idx)%f107pid) + str = 'Pervious day 10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%f107pid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'kp',pio_double,(/timdim/),file(fil_idx)%kpid) + str = 'Daily planetary K geomagnetic index' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%kpid, 'long_name', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'ap',pio_double,(/timdim/),file(fil_idx)%apid) + str = 'Daily planetary A geomagnetic index' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%apid, 'long_name', trim(str)) + endif + if (solar_wind_on) then + + ierr=pio_def_var (file(fil_idx)%File,'byimf',pio_double,(/timdim/),file(fil_idx)%byimfid) + str = 'Y component of the interplanetary magnetic field' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%byimfid, 'long_name', trim(str)) + str = 'nT' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%byimfid, 'units', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'bzimf',pio_double,(/timdim/),file(fil_idx)%bzimfid) + str = 'Z component of the interplanetary magnetic field' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%bzimfid, 'long_name', trim(str)) + str = 'nT' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%bzimfid, 'units', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'swvel',pio_double,(/timdim/),file(fil_idx)%swvelid) + str = 'Solar wind speed' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%swvelid, 'long_name', trim(str)) + str = 'km/sec' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%swvelid, 'units', trim(str)) + + ierr=pio_def_var (file(fil_idx)%File,'swden',pio_double,(/timdim/),file(fil_idx)%swdenid) + str = 'Solar wind ion number density' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%swdenid, 'long_name', trim(str)) + str = 'cm-3' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%swdenid, 'units', trim(str)) + + endif + if (epot_active) then + ierr=pio_def_var (file(fil_idx)%File,'colat_crit1',pio_double,(/timdim/),file(fil_idx)%colat_crit1_id) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%colat_crit1_id, 'long_name', & + 'First co-latitude of electro-potential critical angle') + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%colat_crit1_id, 'units', 'degrees') + + ierr=pio_def_var (file(fil_idx)%File,'colat_crit2',pio_double,(/timdim/),file(fil_idx)%colat_crit2_id) + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%colat_crit2_id, 'long_name',& + 'Second co-latitude of electro-potential critical angle') + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%colat_crit2_id, 'units', 'degrees') + endif + end if + + +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_def_var (file(fil_idx)%File,'tsec ',pio_int,(/timdim/), file(fil_idx)%tsecid) + str = 'current seconds of current date needed for scam' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%tsecid, 'long_name', trim(str)) +#endif + ierr=pio_def_var (file(fil_idx)%File,'nsteph ',pio_int,(/timdim/),file(fil_idx)%nstephid) + str = 'current timestep' + ierr=pio_put_att (file(fil_idx)%File, file(fil_idx)%nstephid, 'long_name', trim(str)) + end if ! .not. is_satfile + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Create variables and attributes for field list + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do f = 1, nflds(fil_idx) + + !! Collect some field properties + call AvgflagToString(file(fil_idx)%hlist(fld_idx)%avgflag, file(fil_idx)%hlist(fld_idx)%time_op) + + if ((file(fil_idx)%hlist(fld_idx)%hwrt_prec == 8) .or. restart) then + ncreal = pio_double + else + ncreal = pio_real + end if + + if(associated(file(fil_idx)%hlist(fld_idx)%field%mdims)) then + mdims => file(fil_idx)%hlist(fld_idx)%field%mdims + mdimsize = size(mdims) + else if(file(fil_idx)%hlist(fld_idx)%field%numlev > 1) then + call endrun('mdims not defined for variable '//trim(file(fil_idx)%hlist(fld_idx)%field%name)) + else + mdimsize=0 + end if + + ! num_patches will loop through the number of patches (or just one + ! for the whole grid) for this field for this file + if (patch_output) then + num_patches = size(file(fil_idx)%patches) + else + num_patches = 1 + end if + if(.not.associated(file(fil_idx)%hlist(fld_idx)%varid)) then + allocate(file(fil_idx)%hlist(fld_idx)%varid(num_patches)) + end if + fname_tmp = strip_suffix(file(fil_idx)%hlist(fld_idx)%field%name) + + if(is_satfile(fil_idx)) then + num_hdims=0 + nfils(fil_idx)=1 + call sat_hist_define(file(fil_idx)%File) + else if (interpolate) then + ! Interpolate can't use normal grid code since we are forcing fields + ! to use interpolate decomp + if (.not. allocated(header_info)) then + ! Safety check + call endrun('h_define: header_info not allocated') + end if + num_hdims = 2 + do i = 1, num_hdims + dimindex(i) = header_info(1)%get_hdimid(i) + nacsdims(i) = header_info(1)%get_hdimid(i) + end do + else if (patch_output) then + ! All patches for this variable should be on the same grid + num_hdims = file(fil_idx)%patches(1)%num_hdims(file(fil_idx)%hlist(fld_idx)%field%decomp_type) + else + ! Normal grid output + ! Find appropriate grid in header_info + if (.not. allocated(header_info)) then + ! Safety check + call endrun('h_define: header_info not allocated') + end if + grd = -1 + do i = 1, size(header_info) + if (header_info(i)%get_gridid() == file(fil_idx)%hlist(fld_idx)%field%decomp_type) then + grd = i + exit + end if + end do + if (grd < 0) then + write(errormsg, '(a,i0,2a)') 'grid, ',file(fil_idx)%hlist(fld_idx)%field%decomp_type,', not found for ',trim(fname_tmp) + call endrun('H_DEFINE: '//errormsg) + end if + num_hdims = header_info(grd)%num_hdims() + do i = 1, num_hdims + dimindex(i) = header_info(grd)%get_hdimid(i) + nacsdims(i) = header_info(grd)%get_hdimid(i) + end do + end if ! is_satfile + + ! + ! Create variables and atributes for fields written out as columns + ! + + do i = 1, num_patches + fname_tmp = strip_suffix(file(fil_idx)%hlist(fld_idx)%field%name) + varid => file(fil_idx)%hlist(fld_idx)%varid(i) + dimids_tmp = dimindex + ! Figure the dimension ID array for this field + ! We have defined the horizontal grid dimensions in dimindex + fdims = num_hdims + do j = 1, mdimsize + fdims = fdims + 1 + dimids_tmp(fdims) = mdimids(mdims(j)) + end do + if(.not. restart) then + ! Only add time dimension if this is not a restart history file + fdims = fdims + 1 + dimids_tmp(fdims) = timdim + end if + if (patch_output) then + ! For patch output, we need new dimension IDs and a different name + call file(fil_idx)%patches(i)%get_var_data(fname_tmp, & + dimids_tmp(1:fdims), file(fil_idx)%hlist(fld_idx)%field%decomp_type) + end if + ! Define the variable + call cam_pio_def_var(file(fil_idx)%File, trim(fname_tmp), ncreal, & + dimids_tmp(1:fdims), varid) + if (mdimsize > 0) then + ierr = pio_put_att(file(fil_idx)%File, varid, 'mdims', mdims(1:mdimsize)) + call cam_pio_handle_error(ierr, 'h_define: cannot define mdims for '//trim(fname_tmp)) + end if + str = file(fil_idx)%hlist(fld_idx)%field%sampling_seq + if (len_trim(str) > 0) then + ierr = pio_put_att(file(fil_idx)%File, varid, 'Sampling_Sequence', trim(str)) + call cam_pio_handle_error(ierr, 'h_define: cannot define Sampling_Sequence for '//trim(fname_tmp)) + end if + + if (file(fil_idx)%hlist(fld_idx)%field%flag_xyfill) then + ! Add both _FillValue and missing_value to cover expectations + ! of various applications. + ! The attribute type must match the data type. + if ((file(fil_idx)%hlist(fld_idx)%hwrt_prec == 8) .or. restart) then + ierr = pio_put_att(file(fil_idx)%File, varid, '_FillValue', & + file(fil_idx)%hlist(fld_idx)%field%fillvalue) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define _FillValue for '//trim(fname_tmp)) + ierr = pio_put_att(file(fil_idx)%File, varid, 'missing_value', & + file(fil_idx)%hlist(fld_idx)%field%fillvalue) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define missing_value for '//trim(fname_tmp)) + else + ierr = pio_put_att(file(fil_idx)%File, varid, '_FillValue', & + REAL(file(fil_idx)%hlist(fld_idx)%field%fillvalue,r4)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define _FillValue for '//trim(fname_tmp)) + ierr = pio_put_att(file(fil_idx)%File, varid, 'missing_value', & + REAL(file(fil_idx)%hlist(fld_idx)%field%fillvalue,r4)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define missing_value for '//trim(fname_tmp)) + end if + end if + + str = file(fil_idx)%hlist(fld_idx)%field%units + if (len_trim(str) > 0) then + ierr=pio_put_att (file(fil_idx)%File, varid, 'units', trim(str)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define units for '//trim(fname_tmp)) + end if + + str = file(fil_idx)%hlist(fld_idx)%field%mixing_ratio + if (len_trim(str) > 0) then + ierr=pio_put_att (file(fil_idx)%File, varid, 'mixing_ratio', trim(str)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define mixing_ratio for '//trim(fname_tmp)) + end if + + str = file(fil_idx)%hlist(fld_idx)%field%long_name + ierr=pio_put_att (file(fil_idx)%File, varid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define long_name for '//trim(fname_tmp)) + + ! Assign field attributes defining valid levels and averaging info + + cell_methods = '' + if (len_trim(file(fil_idx)%hlist(fld_idx)%field%cell_methods) > 0) then + if (len_trim(cell_methods) > 0) then + cell_methods = trim(cell_methods)//' '//trim(file(fil_idx)%hlist(fld_idx)%field%cell_methods) + else + cell_methods = trim(cell_methods)//trim(file(fil_idx)%hlist(fld_idx)%field%cell_methods) + end if + end if + ! Time cell methods is after field method because time averaging is + ! applied later (just before output) than field method which is applied + ! before outfld call. + str = file(fil_idx)%hlist(fld_idx)%time_op + select case (str) + case ('mean', 'maximum', 'minimum', 'standard_deviation') + if (len_trim(cell_methods) > 0) then + cell_methods = trim(cell_methods)//' '//'time: '//str + else + cell_methods = trim(cell_methods)//'time: '//str + end if + end select + if (len_trim(cell_methods) > 0) then + ierr = pio_put_att(file(fil_idx)%File, varid, 'cell_methods', trim(cell_methods)) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define cell_methods for '//trim(fname_tmp)) + end if + if (patch_output) then + ierr = pio_put_att(file(fil_idx)%File, varid, 'basename', & + file(fil_idx)%hlist(fld_idx)%field%name) + call cam_pio_handle_error(ierr, & + 'h_define: cannot define basename for '//trim(fname_tmp)) + end if + + if (restart) then + ! For restart history files, we need to save accumulation counts + fname_tmp = trim(fname_tmp)//'_nacs' + if (.not. associated(file(fil_idx)%hlist(fld_idx)%nacs_varid)) then + allocate(file(fil_idx)%hlist(fld_idx)%nacs_varid) + end if + if (size(file(fil_idx)%hlist(fld_idx)%nacs, 1) > 1) then + call cam_pio_def_var(file(fil_idx)%File, trim(fname_tmp), pio_int, & + nacsdims(1:num_hdims), file(fil_idx)%hlist(fld_idx)%nacs_varid) + else + ! Save just one value representing all chunks + call cam_pio_def_var(file(fil_idx)%File, trim(fname_tmp), pio_int, & + file(fil_idx)%hlist(fld_idx)%nacs_varid) + end if + ! for standard deviation + if (associated(file(fil_idx)%hlist(fld_idx)%sbuf)) then + fname_tmp = strip_suffix(file(fil_idx)%hlist(fld_idx)%field%name) + fname_tmp = trim(fname_tmp)//'_var' + if ( .not.associated(file(fil_idx)%hlist(fld_idx)%sbuf_varid)) then + allocate(file(fil_idx)%hlist(fld_idx)%sbuf_varid) + endif + call cam_pio_def_var(file(fil_idx)%File, trim(fname_tmp), pio_double, & + dimids_tmp(1:fdims), file(fil_idx)%hlist(fld_idx)%sbuf_varid) + endif + end if + end do ! Loop over output patches + end do ! Loop over fields + ! + deallocate(mdimids) + ret = pio_enddef(file(fil_idx)%File) + + if(masterproc) then + write(iulog,*)'H_DEFINE: Successfully opened netcdf file ' + endif + ! + ! Write time-invariant portion of history header + ! + if(.not. is_satfile(fil_idx)) then + if(interpolate) then + call cam_grid_write_var(file(fil_idx)%File, interpolate_info(fil_idx)%grid_id) + else if((.not. patch_output) .or. restart) then + do i = 1, size(file(fil_idx)%grid_ids) + call cam_grid_write_var(file(fil_idx)%File, file(fil_idx)%grid_ids(i)) + end do + else + ! Patch output + do i = 1, size(file(fil_idx)%patches) + call file(fil_idx)%patches(i)%write_vals(file(fil_idx)%File) + end do + end if ! interpolate + if (allocated(lonvar)) then + deallocate(lonvar) + end if + if (allocated(latvar)) then + deallocate(latvar) + end if + + dtime = get_step_size() + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%mdtid, (/dtime/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put mdt') + ! + ! Model date info + ! + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%ndbaseid, (/ndbase/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put ndbase') + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%nsbaseid, (/nsbase/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put nsbase') + + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%nbdateid, (/nbdate/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put nbdate') +#if ( defined BFB_CAM_SCAM_IOP ) + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%bdateid, (/nbdate/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put bdate') +#endif + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%nbsecid, (/nbsec/)) + call cam_pio_handle_error(ierr, 'h_define: cannot put nbsec') + ! + ! Reduced grid info + ! + + end if ! .not. is_satfile + + if (allocated(header_info)) then + do i = 1, size(header_info) + call header_info(i)%deallocate() + end do + deallocate(header_info) + end if + + ! Write the mdim variable data + call write_hist_coord_vars(file(fil_idx)%File, restart) + + end subroutine h_define + + !####################################################################### + + subroutine h_normalize (f, t) + + use cam_history_support, only: dim_index_2d + + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Normalize fields on a history file by the number of accumulations + ! + ! Method: Loop over fields on the file. Need averaging flag and number of + ! accumulations to perform normalization. + ! + !----------------------------------------------------------------------- + ! + ! Input arguments + ! + integer, intent(in) :: f ! field index + integer, intent(in) :: t ! file index + ! + ! Local workspace + ! + type (dim_index_2d) :: dimind ! 2-D dimension index + integer :: c ! chunk (or lat) index + integer :: ib, ie ! beginning and ending indices of first dimension + integer :: jb, je ! beginning and ending indices of second dimension + integer :: begdim3, enddim3 ! Chunk or block bounds + integer :: k ! level + integer :: i, ii + real(r8) :: variance, tmpfill + + logical :: flag_xyfill ! non-applicable xy points flagged with fillvalue + character*1 :: avgflag ! averaging flag + + call t_startf ('h_normalize') + + call file(fil_idx)%hlist(fld_idx)%field%get_bounds(3, begdim3, enddim3) + + ! + ! normalize by number of accumulations for averaged case + ! + flag_xyfill = file(fil_idx)%hlist(fld_idx)%field%flag_xyfill + avgflag = file(fil_idx)%hlist(fld_idx)%avgflag + + do c = begdim3, enddim3 + dimind = file(fil_idx)%hlist(fld_idx)%field%get_dims(c) + + ib = dimind%beg1 + ie = dimind%end1 + jb = dimind%beg2 + je = dimind%end2 + + if (flag_xyfill) then + do k = jb, je + where (file(fil_idx)%hlist(fld_idx)%nacs(ib:ie, c) == 0) + file(fil_idx)%hlist(fld_idx)%hbuf(ib:ie,k,c) = file(fil_idx)%hlist(fld_idx)%field%fillvalue + endwhere + end do + end if + + if (avgflag == 'A' .or. avgflag == 'B' .or. avgflag == 'L') then + if (size(file(fil_idx)%hlist(fld_idx)%nacs, 1) > 1) then + do k = jb, je + where (file(fil_idx)%hlist(fld_idx)%nacs(ib:ie,c) /= 0) + file(fil_idx)%hlist(fld_idx)%hbuf(ib:ie,k,c) = & + file(fil_idx)%hlist(fld_idx)%hbuf(ib:ie,k,c) & + / file(fil_idx)%hlist(fld_idx)%nacs(ib:ie,c) + endwhere + end do + else if(file(fil_idx)%hlist(fld_idx)%nacs(1,c) > 0) then + do k=jb,je + file(fil_idx)%hlist(fld_idx)%hbuf(ib:ie,k,c) = & + file(fil_idx)%hlist(fld_idx)%hbuf(ib:ie,k,c) & + / file(fil_idx)%hlist(fld_idx)%nacs(1,c) + end do + end if + end if + if (avgflag == 'S') then + ! standard deviation ... + ! from http://www.johndcook.com/blog/standard_deviation/ + tmpfill = merge(file(fil_idx)%hlist(fld_idx)%field%fillvalue,0._r8,flag_xyfill) + do k=jb,je + do i = ib,ie + ii = merge(i,1,flag_xyfill) + if (file(fil_idx)%hlist(fld_idx)%nacs(ii,c) > 1) then + variance = file(fil_idx)%hlist(fld_idx)%sbuf(i,k,c)/(file(fil_idx)%hlist(fld_idx)%nacs(ii,c)-1) + file(fil_idx)%hlist(fld_idx)%hbuf(i,k,c) = sqrt(variance) + else + file(fil_idx)%hlist(fld_idx)%hbuf(i,k,c) = tmpfill + endif + end do + end do + endif + end do + + call t_stopf ('h_normalize') + + return + end subroutine h_normalize + + !####################################################################### + + subroutine h_zero (f, t) + use cam_history_support, only: dim_index_2d + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Zero out accumulation buffers for a file + ! + ! Method: Loop through fields on the file + ! + !----------------------------------------------------------------------- + ! + integer, intent(in) :: f ! field index + integer, intent(in) :: t ! file index + ! + ! Local workspace + ! + type (dim_index_2d) :: dimind ! 2-D dimension index + integer :: c ! chunk index + integer :: begdim3 ! on-node chunk or lat start index + integer :: enddim3 ! on-node chunk or lat end index + + call t_startf ('h_zero') + + call file(fil_idx)%hlist(fld_idx)%field%get_bounds(3, begdim3, enddim3) + + do c = begdim3, enddim3 + dimind = file(fil_idx)%hlist(fld_idx)%field%get_dims(c) + file(fil_idx)%hlist(fld_idx)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)=0._r8 + if (associated(file(fil_idx)%hlist(fld_idx)%sbuf)) then ! zero out variance buffer for standard deviation + file(fil_idx)%hlist(fld_idx)%sbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)=0._r8 + endif + end do + file(fil_idx)%hlist(fld_idx)%nacs(:,:) = 0 + + call t_stopf ('h_zero') + + return + end subroutine h_zero + + !####################################################################### + + subroutine dump_field (f, t, restart) + use cam_history_support, only: history_patch_t, dim_index_3d + use cam_grid_support, only: cam_grid_write_dist_array, cam_grid_dimensions + use interp_mod, only : write_interpolated + + ! Dummy arguments + integer, intent(in) :: f + integer, intent(in) :: t + logical, intent(in) :: restart + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Write a variable to a history file using PIO + ! For restart files, also write the accumulation buffer (nacs) + ! + !----------------------------------------------------------------------- + ! Local variables + integer :: ierr + type(var_desc_t), pointer :: varid ! PIO ID for var + type(var_desc_t), pointer :: compid ! PIO ID for vector comp. + integer :: compind ! index of vector comp. + integer :: fdims(8) ! Field file dim sizes + integer :: frank ! Field file rank + integer :: nacsrank ! Field file rank for nacs + type(dim_index_3d) :: dimind ! 3-D dimension index + integer :: adims(3) ! Field array dim sizes + integer :: nadims ! # of used adims + integer :: fdecomp + integer :: num_patches + integer :: mdimsize ! Total # on-node elements + logical :: interpolate + logical :: patch_output + type(history_patch_t), pointer :: patchptr + integer :: i + + interpolate = (interpolate_output(fil_idx) .and. (.not. restart)) + patch_output = (associated(file(fil_idx)%patches) .and. (.not. restart)) + +!!! Get the field's shape and decomposition + + ! Shape on disk + call file(fil_idx)%hlist(fld_idx)%field%get_shape(fdims, frank) + + ! Shape of array + dimind = file(fil_idx)%hlist(fld_idx)%field%get_dims() + call dimind%dim_sizes(adims) + if (adims(2) <= 1) then + adims(2) = adims(3) + nadims = 2 + else + nadims = 3 + end if + fdecomp = file(fil_idx)%hlist(fld_idx)%field%decomp_type + + ! num_patches will loop through the number of patches (or just one + ! for the whole grid) for this field for this file + if (patch_output) then + num_patches = size(file(fil_idx)%patches) + else + num_patches = 1 + end if + + do i = 1, num_patches + varid => file(fil_idx)%hlist(fld_idx)%varid(i) + + if (restart) then + call pio_setframe(file(fil_idx)%File, varid, int(-1,kind=PIO_OFFSET_KIND)) + else + call pio_setframe(file(fil_idx)%File, varid, int(max(1,nfils(fil_idx)),kind=PIO_OFFSET_KIND)) + end if + if (patch_output) then + ! We are outputting patches + patchptr => file(fil_idx)%patches(i) + if (interpolate) then + call endrun('dump_field: interpolate incompatible with regional output') + end if + call patchptr%write_var(file(fil_idx)%File, fdecomp, adims(1:nadims), & + pio_double, file(fil_idx)%hlist(fld_idx)%hbuf, varid) + else + ! We are doing output via the field's grid + if (interpolate) then + mdimsize = file(fil_idx)%hlist(fld_idx)%field%enddim2 - file(fil_idx)%hlist(fld_idx)%field%begdim2 + 1 + if (mdimsize == 0) then + mdimsize = file(fil_idx)%hlist(fld_idx)%field%numlev + end if + if (file(fil_idx)%hlist(fld_idx)%field%meridional_complement > 0) then + compind = file(fil_idx)%hlist(fld_idx)%field%meridional_complement + compid => file(fil_idx)%hlist(compind)%varid(i) + ! We didn't call set frame on the meridional complement field + call pio_setframe(file(fil_idx)%File, compid, int(max(1,nfils(fil_idx)),kind=PIO_OFFSET_KIND)) + call write_interpolated(file(fil_idx)%File, varid, compid, & + file(fil_idx)%hlist(fld_idx)%hbuf, file(fil_idx)%hlist(compind)%hbuf, & + mdimsize, PIO_DOUBLE, fdecomp) + else if (file(fil_idx)%hlist(fld_idx)%field%zonal_complement > 0) then + ! We don't want to double write so do nothing here + ! compind = file(fil_idx)%hlist(fld_idx)%field%zonal_complement + ! compid => file(fil_idx)%hlist(compind)%varid(i) + ! call write_interpolated(file(fil_idx)%File, compid, varid, & + ! file(fil_idx)%hlist(compind)%hbuf, file(fil_idx)%hlist(fld_idx)%hbuf, & + ! mdimsize, PIO_DOUBLE, fdecomp) + else + ! Scalar field + call write_interpolated(file(fil_idx)%File, varid, & + file(fil_idx)%hlist(fld_idx)%hbuf, mdimsize, PIO_DOUBLE, fdecomp) + end if + else if (nadims == 2) then + ! Special case for 2D field (no levels) due to hbuf structure + call cam_grid_write_dist_array(file(fil_idx)%File, fdecomp, & + adims(1:nadims), fdims(1:frank), file(fil_idx)%hlist(fld_idx)%hbuf(:,1,:), varid) + else + call cam_grid_write_dist_array(file(fil_idx)%File, fdecomp, adims, & + fdims(1:frank), file(fil_idx)%hlist(fld_idx)%hbuf, varid) + end if + end if + end do + !! write accumulation counter and variance to hist restart file + if(restart) then + if (associated(file(fil_idx)%hlist(fld_idx)%sbuf) ) then + ! write variance data to restart file for standard deviation calc + if (nadims == 2) then + ! Special case for 2D field (no levels) due to sbuf structure + call cam_grid_write_dist_array(file(fil_idx)%File, fdecomp, adims(1:nadims), & + fdims(1:frank), file(fil_idx)%hlist(fld_idx)%sbuf(:,1,:), file(fil_idx)%hlist(fld_idx)%sbuf_varid) + else + call cam_grid_write_dist_array(file(fil_idx)%File, fdecomp, adims, & + fdims(1:frank), file(fil_idx)%hlist(fld_idx)%sbuf, file(fil_idx)%hlist(fld_idx)%sbuf_varid) + endif + endif + !! NACS + if (size(file(fil_idx)%hlist(fld_idx)%nacs, 1) > 1) then + if (nadims > 2) then + adims(2) = adims(3) + nadims = 2 + end if + call cam_grid_dimensions(fdecomp, fdims(1:2), nacsrank) + call cam_grid_write_dist_array(file(fil_idx)%File, fdecomp, adims(1:nadims), & + fdims(1:nacsrank), file(fil_idx)%hlist(fld_idx)%nacs, file(fil_idx)%hlist(fld_idx)%nacs_varid) + else + ierr = pio_put_var(file(fil_idx)%File, file(fil_idx)%hlist(fld_idx)%nacs_varid, & + file(fil_idx)%hlist(fld_idx)%nacs(:, file(fil_idx)%hlist(fld_idx)%field%begdim3:file(fil_idx)%hlist(fld_idx)%field%enddim3)) + end if + end if + + return + end subroutine dump_field + + !####################################################################### + + logical function write_inithist () + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Set flags that will initiate dump to IC file when OUTFLD and + ! WSHIST are called + ! + !----------------------------------------------------------------------- + ! + use time_manager, only: get_nstep, get_curr_date, get_step_size, is_last_step + ! + ! Local workspace + ! + integer :: yr, mon, day ! year, month, and day components of + ! a date + integer :: nstep ! current timestep number + integer :: ncsec ! current time of day [seconds] + integer :: dtime ! timestep size + + !----------------------------------------------------------------------- + + write_inithist = .false. + + if(is_initfile()) then + + nstep = get_nstep() + call get_curr_date(yr, mon, day, ncsec) + + if (inithist == '6-HOURLY') then + dtime = get_step_size() + write_inithist = nstep /= 0 .and. mod( nstep, nint((6._r8*3600._r8)/dtime) ) == 0 + elseif(inithist == 'DAILY' ) then + write_inithist = nstep /= 0 .and. ncsec == 0 + elseif(inithist == 'MONTHLY' ) then + write_inithist = nstep /= 0 .and. ncsec == 0 .and. day == 1 + elseif(inithist == 'YEARLY' ) then + write_inithist = nstep /= 0 .and. ncsec == 0 .and. day == 1 .and. mon == 1 + elseif(inithist == 'CAMIOP' ) then + write_inithist = nstep == 0 + elseif(inithist == 'ENDOFRUN' ) then + write_inithist = nstep /= 0 .and. is_last_step() + end if + end if + + return + end function write_inithist + + !####################################################################### + + subroutine wshist(regen_hist_file_in) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Driver routine to write fields on history file t + ! + ! + !----------------------------------------------------------------------- + use time_manager, only: get_nstep, get_curr_date, get_curr_time + use time_manager, only: get_step_size + use chem_surfvals, only: chem_surfvals_get, chem_surfvals_co2_rad + use solar_irrad_data, only: sol_tsi + use sat_hist, only: sat_hist_write + use interp_mod, only: set_interp_hfile + use datetime_mod, only: datetime + use cam_pio_utils, only: cam_pio_closefile + + logical, intent(in), optional :: regen_hist_file_in(pfiles) + ! + ! Local workspace + ! + character(len=8) :: cdate ! system date + character(len=8) :: ctime ! system time + + logical :: regen_hist_file(pfiles), restart + integer :: fil_idx ! file index + integer :: fld_idx ! field idx + integer :: start ! starting index required by nf_put_vara + integer :: count1 ! count values required by nf_put_vara + integer :: startc(2) ! start values required by nf_put_vara (character) + integer :: countc(2) ! count values required by nf_put_vara (character) + + integer :: yr, mon, day ! year, month, and day components of a date + integer :: nstep ! current timestep number + integer :: ncdate ! current date in integer format [yyyymmdd] + integer :: ncsec ! current time of day [seconds] + integer :: ndcur ! day component of current time + integer :: nscur ! seconds component of current time + real(r8) :: time ! current time + real(r8) :: tdata(2) ! time interval boundaries + character(len=max_string_len) :: fname ! Filename + logical :: prev ! Label file with previous date rather than current + integer :: ierr +#if ( defined BFB_CAM_SCAM_IOP ) + integer :: tsec ! day component of current time + integer :: dtime ! seconds component of current time +#endif + + if(present(regen_hist_file_in)) then + regen_hist_file = regen_hist_file_in + restart=.true. + file => restarthistory_files + else + regen_hist_file = .false. + restart=.false. + file => history_file + end if + + nstep = get_nstep() + call get_curr_date(yr, mon, day, ncsec) + ncdate = yr*10000 + mon*100 + day + call get_curr_time(ndcur, nscur) + ! + ! Write time-varying portion of history file header + ! + do fil_idx = 1, pfiles + if ( (nflds(fil_idx) == 0) .or. & + (restart .and.(.not.regen_hist_file(fil_idx))))) cycle + ! + ! Check if this is the IC file and if it's time to write. + ! Else, use "nhtfrq" to determine if it's time to write + ! the other history files. + ! + if((.not. restart) .or. regen_hist_file(fil_idx)) then + if( is_initfile(file_index=t) ) then + write_file(fil_idx) = write_inithist() + prev = .false. + else + if (nhtfrq(fil_idx) == 0) then + write_file(fil_idx) = nstep /= 0 .and. day == 1 .and. ncsec == 0 + prev = .true. + else + write_file(fil_idx) = mod(nstep, nhtfrq(fil_idx)) == 0 + prev = .false. + end if + end if + end if + if (write_file(fil_idx) .or. (restart .and. regen_hist_file(fil_idx))) then + if(masterproc) then + if(is_initfile(file_index=t)) then + write(iulog,100) yr,mon,day,ncsec +100 format('WSHIST: writing time sample to Initial Conditions h-file', & + ' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + else if(is_satfile(fil_idx)) then + write(iulog,150) nfils(fil_idx),t,yr,mon,day,ncsec +150 format('WSHIST: writing sat columns ',i6,' to h-file ', & + i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + else if(write_file(fil_idx)) then + write(iulog,200) nfils(fil_idx),t,yr,mon,day,ncsec +200 format('WSHIST: writing time sample ',i3,' to h-file ', & + i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + else if(restart .and. regen_hist_file(fil_idx)) then + write(iulog,300) nfils(fil_idx),t,yr,mon,day,ncsec +300 format('WSHIST: writing history restart ',i3,' to hr-file ', & + i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + end if + write(iulog,*) + end if + ! + ! Starting a new volume => define the metadata + ! + if ( (nfils(fil_idx) == 0) .or. & + (restart .and. regen_hist_file(fil_idx))) then + if(restart) then + rhfilename_spec = '%c.cam' // trim(inst_suffix) // '.rh%t.%y-%m-%d-%s.nc' + fname = interpret_filename_spec(rhfilename_spec, unit=(t-1)) + hrestpath(fil_idx)=fname + else if(is_initfile(file_index=t)) then + fname = interpret_filename_spec( hfilename_spec(fil_idx) ) + else + fname = interpret_filename_spec( hfilename_spec(fil_idx), unit=(t-1), & + prev=prev ) + end if + ! + ! Check that this new filename isn't the same as a previous or current filename + ! + do f = 1, pfiles + if (masterproc.and. trim(fname) == trim(nhfil(fld_idx)) )then + write(iulog,*)'WSHIST: New filename same as old file = ', trim(fname) + write(iulog,*)'Is there an error in your filename specifiers?' + write(iulog,*)'hfilename_spec(', t, ') = ', hfilename_spec(fil_idx) + if ( t /= f )then + write(iulog,*)'hfilename_spec(', f, ') = ', hfilename_spec(fld_idx) + end if + call endrun + end if + end do + if(.not. restart) then + nhfil(fil_idx) = fname + if(masterproc) write(iulog,*)'WSHIST: nhfil(',t,')=',trim(nhfil(fil_idx)) + cpath(fil_idx) = nhfil(fil_idx) + end if + call h_define (t, restart) + end if + + if(is_satfile(fil_idx)) then + call sat_hist_write( file(fil_idx), nflds(fil_idx), nfils(fil_idx)) + else + if(restart) then + start=1 + else + nfils(fil_idx) = nfils(fil_idx) + 1 + start = nfils(fil_idx) + end if + count1 = 1 + ! Setup interpolation data if history file is interpolated + if (interpolate_output(fil_idx) .and. (.not. restart)) then + call set_interp_hfile(t, interpolate_info) + end if + + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%ndcurid,(/start/), (/count1/),(/ndcur/)) + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%nscurid,(/start/), (/count1/),(/nscur/)) + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%dateid,(/start/), (/count1/),(/ncdate/)) + + if (.not. is_initfile(file_index=t)) then + ! Don't write the GHG/Solar forcing data to the IC file. + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%co2vmrid,(/start/), (/count1/),(/chem_surfvals_co2_rad(vmr_in=.true.)/)) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%ch4vmrid,(/start/), (/count1/),(/chem_surfvals_get('CH4VMR')/)) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%n2ovmrid,(/start/), (/count1/),(/chem_surfvals_get('N2OVMR')/)) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%f11vmrid,(/start/), (/count1/),(/chem_surfvals_get('F11VMR')/)) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%f12vmrid,(/start/), (/count1/),(/chem_surfvals_get('F12VMR')/)) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%sol_tsiid,(/start/), (/count1/),(/sol_tsi/)) + + if (solar_parms_on) then + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%f107id, (/start/), (/count1/),(/ f107 /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%f107aid,(/start/), (/count1/),(/ f107a /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%f107pid,(/start/), (/count1/),(/ f107p /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%kpid, (/start/), (/count1/),(/ kp /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%apid, (/start/), (/count1/),(/ ap /) ) + endif + if (solar_wind_on) then + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%byimfid, (/start/), (/count1/),(/ byimf /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%bzimfid, (/start/), (/count1/),(/ bzimf /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%swvelid, (/start/), (/count1/),(/ swvel /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%swdenid, (/start/), (/count1/),(/ swden /) ) + endif + if (epot_active) then + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%colat_crit1_id, (/start/), (/count1/),(/ epot_crit_colats(1) /) ) + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%colat_crit2_id, (/start/), (/count1/),(/ epot_crit_colats(2) /) ) + endif + end if + + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%datesecid,(/start/),(/count1/),(/ncsec/)) +#if ( defined BFB_CAM_SCAM_IOP ) + dtime = get_step_size() + tsec=dtime*nstep + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%tsecid,(/start/),(/count1/),(/tsec/)) +#endif + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%nstephid,(/start/),(/count1/),(/nstep/)) + time = ndcur + nscur/86400._r8 + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%timeid, (/start/),(/count1/),(/time/)) + + startc(1) = 1 + startc(2) = start + countc(1) = 2 + countc(2) = 1 + if (is_initfile(file_index=t)) then + tdata = time ! Inithist file is always instantanious data + else + tdata(1) = beg_time(fil_idx) + tdata(2) = time + end if + ierr=pio_put_var (file(fil_idx)%File, file(fil_idx)%tbndid, startc, countc, tdata) + if(.not.restart) beg_time(fil_idx) = time ! update beginning time of next interval + startc(1) = 1 + startc(2) = start + countc(1) = 8 + countc(2) = 1 + call datetime (cdate, ctime) + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%date_writtenid, startc, countc, (/cdate/)) + ierr = pio_put_var (file(fil_idx)%File, file(fil_idx)%time_writtenid, startc, countc, (/ctime/)) + + if(.not. restart) then + !$OMP PARALLEL DO PRIVATE (fld_idx) + do f=1,nflds(fil_idx) + ! Normalized averaged fields + if (file(fil_idx)%hlist(fld_idx)%avgflag /= 'I') then + call h_normalize (f, t) + end if + end do + end if + ! + ! Write field to history file. Note that this is NOT threaded due to netcdf limitations + ! + call t_startf ('dump_field') + do f=1,nflds(fil_idx) + call dump_field(f, t, restart) + end do + call t_stopf ('dump_field') + ! + ! Zero history buffers and accumulators now that the fields have been written. + ! + + + + if(restart) then + do f=1,nflds(fil_idx) + if(associated(file(fil_idx)%hlist(fld_idx)%varid)) then + deallocate(file(fil_idx)%hlist(fld_idx)%varid) + nullify(file(fil_idx)%hlist(fld_idx)%varid) + end if + end do + call cam_pio_closefile(file(fil_idx)%File) + else + !$OMP PARALLEL DO PRIVATE (fld_idx) + do f=1,nflds(fil_idx) + call h_zero (f, t) + end do + end if + end if + end if + + end do + + return + end subroutine wshist + + !####################################################################### + + subroutine addfld_1d(fname, vdim_name, avgflag, units, long_name, & + gridname, flag_xyfill, sampling_seq, standard_name, fill_value) + + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the master field list + ! + ! Method: Put input arguments of field name, units, number of levels, + ! averaging flag, and long name into a type entry in the global + ! master field list (masterlist). + ! + !----------------------------------------------------------------------- + + ! + ! Arguments + ! + character(len=*), intent(in) :: fname ! field name (max_fieldname_len) + character(len=*), intent(in) :: vdim_name ! NetCDF dimension name (or scalar coordinate) + character(len=1), intent(in) :: avgflag ! averaging flag + character(len=*), intent(in) :: units ! units of fname (max_chars) + character(len=*), intent(in) :: long_name ! long name of field (max_chars) + + character(len=*), intent(in), optional :: gridname ! decomposition type + logical, intent(in), optional :: flag_xyfill ! non-applicable xy points flagged with fillvalue + character(len=*), intent(in), optional :: sampling_seq ! sampling sequence - if not every timestep, + ! how often field is sampled: + ! every other; only during LW/SW radiation calcs, etc. + character(len=*), intent(in), optional :: standard_name ! CF standard name (max_chars) + real(r8), intent(in), optional :: fill_value + + ! + ! Local workspace + ! + character(len=max_chars), allocatable :: dimnames(:) + integer :: index + + if (trim(vdim_name) == trim(horiz_only)) then + allocate(dimnames(0)) + else + index = get_hist_coord_index(trim(vdim_name)) + if (index < 1) then + call endrun('ADDFLD: Invalid coordinate, '//trim(vdim_name)) + end if + allocate(dimnames(1)) + dimnames(1) = trim(vdim_name) + end if + call addfld(fname, dimnames, avgflag, units, long_name, gridname, & + flag_xyfill, sampling_seq, standard_name, fill_value) + + end subroutine addfld_1d + + subroutine addfld_nd(fname, dimnames, avgflag, units, long_name, & + gridname, flag_xyfill, sampling_seq, standard_name, fill_value) + + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the master field list + ! + ! Method: Put input arguments of field name, units, number of levels, + ! averaging flag, and long name into a type entry in the global + ! master field list (masterlist). + ! + !----------------------------------------------------------------------- + use cam_history_support, only: fillvalue, hist_coord_find_levels + use cam_grid_support, only: cam_grid_id, cam_grid_is_zonal + use cam_grid_support, only: cam_grid_get_coord_names + use constituents, only: pcnst, cnst_get_ind, cnst_get_type_byind + + ! + ! Arguments + ! + character(len=*), intent(in) :: fname ! field name (max_fieldname_len) + character(len=*), intent(in) :: dimnames(:) ! NetCDF dimension names (except grid dims) + character(len=1), intent(in) :: avgflag ! averaging flag + character(len=*), intent(in) :: units ! units of fname (max_chars) + character(len=*), intent(in) :: long_name ! long name of field (max_chars) + + character(len=*), intent(in), optional :: gridname ! decomposition type + logical, intent(in), optional :: flag_xyfill ! non-applicable xy points flagged with fillvalue + character(len=*), intent(in), optional :: sampling_seq ! sampling sequence - if not every timestep, + ! how often field is sampled: + ! every other; only during LW/SW radiation calcs, etc. + character(len=*), intent(in), optional :: standard_name ! CF standard name (max_chars) + real(r8), intent(in), optional :: fill_value + + ! + ! Local workspace + ! + character(len=max_fieldname_len) :: fname_tmp ! local copy of fname + character(len=max_fieldname_len) :: coord_name ! for cell_methods + character(len=128) :: errormsg + character(len=3) :: mixing_ratio + type(master_entry), pointer :: listentry + + integer :: dimcnt + integer :: idx + + if (hfiles_defined) then + call endrun ('ADDFLD: Attempt to add field '//trim(fname)//' after history files set') + end if + + ! + ! Ensure that new field name is not all blanks + ! + if (len_trim(fname)==0) then + call endrun('ADDFLD: blank field name not allowed') + end if + ! + ! Ensure that new field name is not longer than allowed + ! (strip "&IC" suffix if it exists) + ! + fname_tmp = fname + fname_tmp = strip_suffix(fname_tmp) + + if (len_trim(fname_tmp) > fieldname_len) then + write(iulog,*)'ADDFLD: field name cannot be longer than ',fieldname_len,' characters long' + write(iulog,*)'Field name: ',fname + write(errormsg, *) 'Field name, "', trim(fname), '" is too long' + call endrun('ADDFLD: '//trim(errormsg)) + end if + ! + ! Ensure that new field doesn't already exist + ! + listentry => get_entry_by_name(masterlinkedlist, fname) + if(associated(listentry)) then + call endrun ('ADDFLD: '//fname//' already on list') + end if + + ! If the field is an advected constituent determine whether its concentration + ! is based on dry or wet air. + call cnst_get_ind(fname_tmp, idx, abort=.false.) + mixing_ratio = '' + if (idx > 0) then + mixing_ratio = cnst_get_type_byind(idx) + end if + + ! Add field to Master Field List arrays fieldn and iflds + ! + allocate(listentry) + listentry%field%name = fname + listentry%field%long_name = long_name + listentry%field%numlev = 1 ! Will change if lev or ilev in shape + listentry%field%units = units + listentry%field%mixing_ratio = mixing_ratio + listentry%field%meridional_complement = -1 + listentry%field%zonal_complement = -1 + listentry%hfileindx(:) = -1 + listentry%act_somefile = .false. + listentry%actflag(:) = .false. + + ! Make sure we have a valid gridname + if (present(gridname)) then + listentry%field%decomp_type = cam_grid_id(trim(gridname)) + else + listentry%field%decomp_type = cam_grid_id('physgrid') + end if + if (listentry%field%decomp_type < 0) then + write(errormsg, *) 'Invalid grid name, "', trim(gridname), '" for ', & + trim(fname) + call endrun('ADDFLD: '//trim(errormsg)) + end if + + ! + ! Indicate sampling sequence of field (i.e., how often "outfld" is called) + ! If not every timestep (default), then give a descriptor indicating the + ! sampling pattern. Currently, the only valid value is "rad_lwsw" for sampling + ! during LW/SW radiation timesteps only + ! + if (present(sampling_seq)) then + listentry%field%sampling_seq = sampling_seq + else + listentry%field%sampling_seq = ' ' + end if + ! Indicate if some field pre-processing occurred (e.g., zonal mean) + if (cam_grid_is_zonal(listentry%field%decomp_type)) then + call cam_grid_get_coord_names(listentry%field%decomp_type, coord_name, errormsg) + ! Zonal method currently hardcoded to 'mean'. + listentry%field%cell_methods = trim(coord_name)//': mean' + else + listentry%field%cell_methods = '' + end if + ! + ! Whether to apply xy fillvalue: default is false + ! + if (present(flag_xyfill)) then + listentry%field%flag_xyfill = flag_xyfill + else + listentry%field%flag_xyfill = .false. + end if + + ! + ! Allow external packages to have fillvalues different than default + ! + + if(present(fill_value)) then + listentry%field%fillvalue = fill_value + else + listentry%field%fillvalue = fillvalue + endif + + ! + ! Process shape + ! + + if (associated(listentry%field%mdims)) then + deallocate(listentry%field%mdims) + end if + nullify(listentry%field%mdims) + dimcnt = size(dimnames) + allocate(listentry%field%mdims(dimcnt)) + call lookup_hist_coord_indices(dimnames, listentry%field%mdims) + if(dimcnt > maxvarmdims) then + maxvarmdims = dimcnt + end if + ! Check for subcols (currently limited to first dimension) + listentry%field%is_subcol = .false. + if (size(dimnames) > 0) then + if (trim(dimnames(1)) == 'psubcols') then + if (listentry%field%decomp_type /= cam_grid_id('physgrid')) then + write(errormsg, *) "Cannot add ", trim(fname), & + "Subcolumn history output only allowed on physgrid" + call endrun("ADDFLD: "//errormsg) + listentry%field%is_subcol = .true. + end if + end if + end if + ! Levels + listentry%field%numlev = hist_coord_find_levels(dimnames) + if (listentry%field%numlev <= 0) then + listentry%field%numlev = 1 + end if + + ! + ! Dimension history info based on decomposition type (grid) + ! + call set_field_dimensions(listentry%field) + + ! + ! These 2 fields are used only in master field list, not runtime field list + ! + listentry%avgflag(:) = avgflag + listentry%actflag(:) = .false. + + do dimcnt = 1, pfiles + call AvgflagToString(avgflag, listentry%time_op(dimcnt)) + end do + + nullify(listentry%next_entry) + + call add_entry_to_master(listentry) + return + end subroutine addfld_nd + + !####################################################################### + + ! field_part_of_vector: Determinie if fname is part of a vector set + ! Optionally fill in the names of the vector set fields + logical function field_part_of_vector(fname, meridional_name, zonal_name) + + ! Dummy arguments + character(len=*), intent(in) :: fname + character(len=*), optional, intent(out) :: meridional_name + character(len=*), optional, intent(out) :: zonal_name + + ! Local variables + type(master_entry), pointer :: listentry + + listentry => get_entry_by_name(masterlinkedlist, fname) + if (associated(listentry)) then + if ( (len_trim(listentry%meridional_field) > 0) .or. & + (len_trim(listentry%zonal_field) > 0)) then + field_part_of_vector = .true. + if (present(meridional_name)) then + meridional_name = listentry%meridional_field + end if + if (present(zonal_name)) then + zonal_name = listentry%zonal_field + end if + else + field_part_of_vector = .false. + end if + else + field_part_of_vector = .false. + end if + if (.not. field_part_of_vector) then + if (present(meridional_name)) then + meridional_name = '' + end if + if (present(zonal_name)) then + zonal_name = '' + end if + end if + + end function field_part_of_vector + + + ! register_vector_field: Register a pair of history field names as + ! being a vector complement set. + ! This information is used to set up interpolated history output. + ! NB: register_vector_field must be called after both fields are defined + ! with addfld + subroutine register_vector_field(zonal_field_name, meridional_field_name) + + ! Dummy arguments + character(len=*), intent(in) :: zonal_field_name + character(len=*), intent(in) :: meridional_field_name + + ! Local variables + type(master_entry), pointer :: mlistentry + type(master_entry), pointer :: zlistentry + character(len=*), parameter :: subname = 'REGISTER_VECTOR_FIELD' + character(len=max_chars) :: errormsg + + if (hfiles_defined) then + write(errormsg, '(5a)') ': Attempt to register vector field (', & + trim(zonal_field_name), ', ', trim(meridional_field_name), & + ') after history files set' + call endrun (trim(subname)//errormsg) + end if + + ! Look for the field IDs + zlistentry => get_entry_by_name(masterlinkedlist, zonal_field_name) + mlistentry => get_entry_by_name(masterlinkedlist, meridional_field_name) + ! Has either of these fields been previously registered? + if (associated(mlistentry)) then + if (len_trim(mlistentry%meridional_field) > 0) then + write(errormsg, '(9a)') ': ERROR attempting to register vector ', & + 'field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', & + trim(meridional_field_name), & + ' has been registered as part of a vector field with ', & + trim(mlistentry%meridional_field) + call endrun (trim(subname)//errormsg) + else if (len_trim(mlistentry%zonal_field) > 0) then + write(errormsg, '(9a)') ': ERROR attempting to register vector ', & + 'field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', & + trim(meridional_field_name), & + ' has been registered as part of a vector field with ', & + trim(mlistentry%zonal_field) + call endrun (trim(subname)//errormsg) + end if + end if + if (associated(zlistentry)) then + if (len_trim(zlistentry%meridional_field) > 0) then + write(errormsg, '(9a)') ': ERROR attempting to register vector ', & + 'field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', trim(zonal_field_name), & + ' has been registered as part of a vector field with ', & + trim(zlistentry%meridional_field) + call endrun (trim(subname)//errormsg) + else if (len_trim(zlistentry%zonal_field) > 0) then + write(errormsg, '(9a)') ': ERROR attempting to register vector ', & + 'field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', trim(zonal_field_name), & + ' has been registered as part of a vector field with ', & + trim(zlistentry%meridional_field) + call endrun (trim(subname)//errormsg) + end if + end if + if(associated(mlistentry) .and. associated(zlistentry)) then + zlistentry%meridional_field = mlistentry%field%name + zlistentry%zonal_field = '' + mlistentry%meridional_field = '' + mlistentry%zonal_field = zlistentry%field%name + else if (associated(mlistentry)) then + write(errormsg, '(8a)') ': ERROR attempting to register vector', & + ' field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', & + trim(zonal_field_name), ' is not defined' + call endrun (trim(subname)//errormsg) + else if (associated(zlistentry)) then + write(errormsg, '(8a)') ': ERROR attempting to register vector', & + ' field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), ', & + trim(meridional_field_name), ' is not defined' + call endrun (trim(subname)//errormsg) + else + write(errormsg, '(6a)') ': ERROR attempting to register vector', & + ' field (', trim(zonal_field_name), ', ', & + trim(meridional_field_name), '), neither field is defined' + call endrun (trim(subname)//errormsg) + end if + end subroutine register_vector_field + + subroutine add_entry_to_master( newentry) + type(master_entry), target, intent(in) :: newentry + type(master_entry), pointer :: listentry + + if(associated(masterlinkedlist)) then + listentry => masterlinkedlist + do while(associated(listentry%next_entry)) + listentry=>listentry%next_entry + end do + listentry%next_entry=>newentry + else + masterlinkedlist=>newentry + end if + + end subroutine add_entry_to_master + + !####################################################################### + + subroutine wrapup (rstwr, nlend) + ! + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Close history files. + ! + ! Method: + ! This routine will close any full hist. files + ! or any hist. file that has data on it when restart files are being + ! written. + ! If a partially full history file was disposed (for restart + ! purposes), then wrapup will open that unit back up and position + ! it for appending new data. + ! + ! Original version: CCM2 + ! + !----------------------------------------------------------------------- + ! + use pio, only : pio_file_is_open + use shr_kind_mod, only: r8 => shr_kind_r8 + use ioFileMod + use time_manager, only: get_nstep, get_curr_date, get_curr_time + use cam_pio_utils, only: cam_pio_openfile, cam_pio_closefile + + ! + ! Input arguments + ! + logical, intent(in) :: rstwr ! true => restart files are written this timestep + logical, intent(in) :: nlend ! Flag if time to end + + ! + ! Local workspace + ! + integer :: nstep ! current timestep number + integer :: ncsec ! time of day relative to current date [secs] + integer :: ndcur ! days component of current time + integer :: nscur ! seconds component of current time + integer :: yr, mon, day ! year, month, day components of a date + + logical :: lfill (pfiles) ! Is history file ready to dispose? + logical :: lhdisp ! true => history file is disposed + logical :: lhfill ! true => history file is full + + integer :: t ! History file number + integer :: f + real(r8) :: tday ! Model day number for printout + !----------------------------------------------------------------------- + + file => history_file + + nstep = get_nstep() + call get_curr_date(yr, mon, day, ncsec) + call get_curr_time(ndcur, nscur) + ! + !----------------------------------------------------------------------- + ! Dispose history files. + !----------------------------------------------------------------------- + ! + ! Begin loop over pfiles (the no. of declared history files - primary + ! and auxiliary). This loop disposes a history file to Mass Store + ! when appropriate. + ! + do fil_idx = 1, pfiles + if (nflds(fil_idx) == 0) cycle + + lfill(fil_idx) = .false. + ! + ! Find out if file is full + ! + if (write_file(fil_idx) .and. nfils(fil_idx) >= mfilt(fil_idx)) then + lfill(fil_idx) = .true. + endif + ! + ! Dispose history file if + ! 1) file is filled or + ! 2) this is the end of run and file has data on it or + ! 3) restarts are being put out and history file has data on it + ! + if (lfill(fil_idx) .or. (nlend .and. nfils(fil_idx) >= 1) .or. (rstwr .and. nfils(fil_idx) >= 1)) then + ! + ! Dispose history file + ! + ! + ! Is this the 0 timestep data of a monthly run? + ! If so, just close primary unit do not dispose. + ! + if (masterproc) write(iulog,*)'WRAPUP: nf_close(',t,')=',trim(nhfil(fil_idx)) + if(pio_file_is_open(file(fil_idx)%File)) then + if (nlend .or. lfill(fil_idx)) then + do f=1,nflds(fil_idx) + if (associated(file(fil_idx)%hlist(fld_idx)%varid)) then + deallocate(file(fil_idx)%hlist(fld_idx)%varid) + nullify(file(fil_idx)%hlist(fld_idx)%varid) + end if + end do + end if + call cam_pio_closefile(file(fil_idx)%File) + end if + if (nhtfrq(fil_idx) /= 0 .or. nstep > 0) then + + ! + ! Print information concerning model output. + ! Model day number = iteration number of history file data * delta-t / (seconds per day) + ! + tday = ndcur + nscur/86400._r8 + if(masterproc) then + if (t==1) then + write(iulog,*)' Primary history file' + else + write(iulog,*)' Auxiliary history file number ', t-1 + end if + write(iulog,9003)nstep,nfils(fil_idx),tday + write(iulog,9004) + end if + ! + ! Auxilary files may have been closed and saved off without being full. + ! We must reopen the files and position them for more data. + ! Must position auxiliary files if not full + ! + if (.not.nlend .and. .not.lfill(fil_idx)) then + call cam_PIO_openfile (file(fil_idx)%File, nhfil(fil_idx), PIO_WRITE) + call h_inquire(fil_idx) + end if + endif ! if 0 timestep of montly run**** + end if ! if time dispose history fiels*** + end do ! do pfiles + ! + ! Reset number of files on each history file + ! + do fil_idx = 1, pfiles + if (nflds(fil_idx) == 0) cycle + lhfill = write_file(fil_idx) .and. nfils(fil_idx) >= mfilt(fil_idx) + lhdisp = lhfill .or. (nlend .and. nfils(fil_idx) >= 1) .or. & + (rstwr .and. nfils(fil_idx) >= 1) + if (lhfill.and.lhdisp) then + nfils(fil_idx) = 0 + endif + end do + return +9003 format(' Output at NSTEP = ',i10,/, & + ' Number of time samples on this file = ',i10,/, & + ' Model Day = ',f10.2) +9004 format('---------------------------------------') + end subroutine wrapup + + !####################################################################### + + subroutine bld_outfld_hash_tbls() + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Build primary and overflow hash tables for outfld processing. + ! + ! Steps: + ! 1) Foreach field on masterlist, find all collisions. + ! 2) Given the number of collisions, verify overflow table has sufficient + ! space. + ! 3) Build primary and overflow indices. + ! + !----------------------------------------------------------------------- + ! + ! Local. + ! + integer :: ff + integer :: ii + integer :: itemp + integer :: ncollisions + integer :: hash_key + type(master_entry), pointer :: listentry + ! + ! 1) Find all collisions. + ! + tbl_hash_pri = 0 + + ff=0 + allocate(masterlist(nfmaster)) + listentry=>masterlinkedlist + do while(associated(listentry)) + ff=ff+1 + masterlist(ff)%thisentry=>listentry + listentry=>listentry%next_entry + end do + if(ff /= nfmaster) then + write(iulog,*) 'nfmaster = ',nfmaster, ' ff=',ff + call endrun('mismatch in expected size of nfmaster') + end if + + + do ff = 1, nfmaster + hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name) + tbl_hash_pri(hash_key) = tbl_hash_pri(hash_key) + 1 + end do + + ! + ! 2) Count number of collisions and define start of a individual + ! collision's chain in overflow table. A collision is defined to be any + ! location in tbl_hash_pri that has a value > 1. + ! + ncollisions = 0 + do ii = 0, tbl_hash_pri_sz-1 + if ( tbl_hash_pri(ii) > 1 ) then ! Define start of chain in O.F. table + itemp = tbl_hash_pri(ii) + tbl_hash_pri(ii) = -(ncollisions + 1) + ncollisions = ncollisions + itemp + 1 + end if + end do + + if ( ncollisions > tbl_hash_oflow_sz ) then + write(iulog,*) 'BLD_OUTFLD_HASH_TBLS: ncollisions > tbl_hash_oflow_sz', & + ncollisions, tbl_hash_oflow_sz + call endrun() + end if + + ! + ! 3) Build primary and overflow tables. + ! i - set collisions in tbl_hash_pri to point to their respective + ! chain in the overflow table. + ! + tbl_hash_oflow = 0 + + do ff = 1, nfmaster + hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name) + if ( tbl_hash_pri(hash_key) < 0 ) then + ii = abs(tbl_hash_pri(hash_key)) + tbl_hash_oflow(ii) = tbl_hash_oflow(ii) + 1 + tbl_hash_oflow(ii+tbl_hash_oflow(ii)) = ff + else + tbl_hash_pri(hash_key) = ff + end if + end do + + ! + ! Dump out primary and overflow hashing tables. + ! + ! if ( masterproc ) then + ! do ii = 0, tbl_hash_pri_sz-1 + ! if ( tbl_hash_pri(ii) /= 0 ) write(iulog,666) 'tbl_hash_pri', ii, tbl_hash_pri(ii) + ! end do + ! + ! do ii = 1, tbl_hash_oflow_sz + ! if ( tbl_hash_oflow(ii) /= 0 ) write(iulog,666) 'tbl_hash_oflow', ii, tbl_hash_oflow(ii) + ! end do + ! + ! itemp = 0 + ! ii = 1 + ! do + ! if ( tbl_hash_oflow(ii) == 0 ) exit + ! itemp = itemp + 1 + ! write(iulog,*) 'Overflow chain ', itemp, ' has ', tbl_hash_oflow(ii), ' entries:' + ! do ff = 1, tbl_hash_oflow(ii) ! dump out colliding names on this chain + ! write(iulog,*) ' ', ff, ' = ', tbl_hash_oflow(ii+ff), & + ! ' ', masterlist(tbl_hash_oflow(ii+ff))%thisentry%field%name + ! end do + ! ii = ii + tbl_hash_oflow(ii) +1 !advance pointer to start of next chain + ! end do + ! end if + + return +666 format(1x, a, '(', i4, ')', 1x, i6) + + end subroutine bld_outfld_hash_tbls + + !####################################################################### + + subroutine bld_hfilefld_indices + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Set history file field indicies in masterlist for each + ! field defined on every file. + ! + ! Note: because of restart processing, the actflag field is cleared and + ! then set only for active output fields on the different history + ! files. + ! + !----------------------------------------------------------------------- + ! + ! Arguments: + ! + + ! + ! Local. + ! + integer :: f + integer :: t + + ! + ! Initialize hfileindx to an invalid value. + ! + type(master_entry), pointer :: listentry + + ! reset all the active flags to false + ! this is needed so that restarts work properly -- fvitt + listentry=>masterlinkedlist + do while(associated(listentry)) + listentry%actflag(:) = .false. + listentry%act_somefile = .false. + listentry=>listentry%next_entry + end do + + do t = 1, pfiles + do f = 1, nflds(fil_idx) + listentry => get_entry_by_name(masterlinkedlist, file(fil_idx)%hlist(fld_idx)%field%name) + if(.not.associated(listentry)) then + write(iulog,*) 'BLD_HFILEFLD_INDICES: something wrong, field not found on masterlist' + write(iulog,*) 'BLD_HFILEFLD_INDICES: t, f, ff = ', t, f + write(iulog,*) 'BLD_HFILEFLD_INDICES: file%name = ', file(fil_idx)%hlist(fld_idx)%field%name + call endrun + end if + listentry%act_somefile = .true. + listentry%actflag(fil_idx) = .true. + listentry%hfileindx(fil_idx) = f + end do + end do + + ! + ! set flag indicating h-file contents are now defined (needed by addfld) + ! + hfiles_defined = .true. + + return + end subroutine bld_hfilefld_indices + + !####################################################################### + + logical function hist_fld_active(fname) + ! + !------------------------------------------------------------------------ + ! + ! Purpose: determine if a field is active on any history file + ! + !------------------------------------------------------------------------ + ! + ! Arguments + ! + character(len=*), intent(in) :: fname ! Field name + ! + ! Local variables + ! + character*(max_fieldname_len) :: fname_loc ! max-char equivalent of fname + integer :: ff ! masterlist index pointer + !----------------------------------------------------------------------- + + fname_loc = fname + ff = get_masterlist_indx(fname_loc) + if ( ff < 0 ) then + hist_fld_active = .false. + else + hist_fld_active = masterlist(ff)%thisentry%act_somefile + end if + + end function hist_fld_active + + !####################################################################### + + function hist_fld_col_active(fname, lchnk, numcols) + use cam_history_support, only: history_patch_t + + ! Determine whether each column in a field is active on any history file. + ! The purpose of this routine is to provide information which would allow + ! a diagnostic physics parameterization to only be run on a subset of + ! columns in the case when only column or regional output is requested. + ! + ! **N.B.** The field is assumed to be using the physics decomposition. + + ! Arguments + character(len=*), intent(in) :: fname ! Field name + integer, intent(in) :: lchnk ! chunk ID + integer, intent(in) :: numcols ! Size of return array + + ! Return value + logical :: hist_fld_col_active(numcols) + + ! Local variables + integer :: ff ! masterlist index pointer + integer :: i + integer :: t ! history file (fil_idx) index + integer :: f ! field index + integer :: decomp + logical :: activeloc(numcols) + integer :: num_patches + logical :: patch_output + logical :: found + type(history_patch_t), pointer :: patchptr + + type (active_entry), pointer :: file(:) + + !----------------------------------------------------------------------- + + ! Initialize to false. Then look to see if and where active. + hist_fld_col_active = .false. + + ! Check for name in the master list. + call get_field_properties(fname, found, file_out=file, ff_out=ff) + + ! If not in master list then return. + if (.not. found) return + + ! If in master list, but not active on any file then return + if (.not. masterlist(ff)%thisentry%act_somefile) return + + ! Loop over history files and check for the field/column in each one + do t = 1, pfiles + + ! Is the field active in this file? If not the cycle to next file. + if (.not. masterlist(ff)%thisentry%actflag(fil_idx)) cycle + + f = masterlist(ff)%thisentry%hfileindx(fil_idx) + decomp = file(fil_idx)%hlist(fld_idx)%field%decomp_type + patch_output = associated(file(fil_idx)%patches) + + ! Check whether this file has patch (column) output. + if (patch_output) then + num_patches = size(file(fil_idx)%patches) + + do i = 1, num_patches + patchptr => file(fil_idx)%patches(i) + activeloc = .false. + call patchptr%active_cols(decomp, lchnk, activeloc) + hist_fld_col_active = hist_fld_col_active .or. activeloc + end do + else + + ! No column output has been requested. In that case the field has + ! global output which implies all columns are active. No need to + ! check any other history files. + hist_fld_col_active = .true. + exit + + end if + + end do ! history files + + end function hist_fld_col_active + +end module cam_history diff --git a/src/history/cam_history_support.F90 b/src/history/cam_history_support.F90 new file mode 100644 index 00000000..703fe2fb --- /dev/null +++ b/src/history/cam_history_support.F90 @@ -0,0 +1,2019 @@ +module cam_history_support + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! + !! cam_history_support is used by cam_history as well as by the dycores + !! (for vertical coordinate and "mdim" support). Some parameters are + !! also referenced by cam_grid_support (although those could be copied + !! if necessary). + !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use shr_kind_mod, only: r8=>shr_kind_r8 + use pio, only: var_desc_t, file_desc_t, PIO_MAX_NAME + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use cam_grid_support, only: cam_grid_patch_t, cam_grid_header_info_t + use cam_grid_support, only: max_hcoordname_len + use cam_pio_utils, only: cam_pio_handle_error + + implicit none + private + save + + ! max_fieldname_len = max chars for field name + integer, parameter, public :: max_fieldname_len = PIO_MAX_NAME + ! default fill value for history NetCDF fields + real(r8), parameter, public :: hist_default_fillvalue = 1.e36_r8 + + ! A special symbol for declaring a field which has no vertical or + ! non-grid dimensions. It is here (rather than cam_history) so that it + ! be checked by add_hist_coord + character(len=10), parameter, public :: horiz_only = 'horiz_only' + + type, public :: history_patch_t + character(len=max_chars) :: namelist_entry = '' + ! lon_axis_name and lat_axis_name only used if collected_output = .false. + character(len=max_fieldname_len) :: lon_axis_name = '' + character(len=max_fieldname_len) :: lat_axis_name = '' + logical :: collected_output + ! There is one patch for every grid and one header_info for every patch + type(cam_grid_patch_t), pointer :: patches(:) => NULL() + type (cam_grid_header_info_t), pointer :: header_info(:) => NULL() + contains + procedure :: write_attrs => history_patch_write_attrs + procedure :: write_vals => history_patch_write_vals + procedure :: field_name => history_patch_field_name + procedure :: num_hdims => history_patch_num_hdims + procedure :: get_var_data => history_patch_get_var_data + procedure :: write_var => history_patch_write_var + procedure :: compact => history_patch_compact + procedure :: active_cols => history_patch_active_cols + procedure :: deallocate => history_patch_deallocate + end type history_patch_t + + ! + ! dim_index_2d, dim_index_3d: 2-D & 3-D dimension index lower & upper bounds + ! + type, public :: dim_index_2d ! 2-D dimension index + integer :: beg1, end1 ! lower & upper bounds of 1st dimension + integer :: beg2, end2 ! lower & upper bounds of 2nd dimension + contains + procedure :: dim_sizes_2d => dim_index_2d_dim_sizes_2d + procedure :: dim_sizes_arr => dim_index_2d_dim_size_arr + generic :: dim_sizes => dim_sizes_arr, dim_sizes_2d + end type dim_index_2d + + type, public :: dim_index_3d ! 3-D dimension index + integer :: beg1, end1 ! lower & upper bounds of 1st dimension + integer :: beg2, end2 ! lower & upper bounds of 2nd dimension + integer :: beg3, end3 ! lower & upper bounds of 3rd dimension + contains + procedure :: dim_sizes_3d => dim_index_3d_dim_sizes_3d + procedure :: dim_sizes_arr => dim_index_3d_dim_size_arr + generic :: dim_sizes => dim_sizes_arr, dim_sizes_3d + end type dim_index_3d + + !--------------------------------------------------------------------------- + ! + ! field_info: A derived type containing information in an addfld call. + ! + !--------------------------------------------------------------------------- + type, public :: field_info + + ! flag_xyfill: non-applicable xy points flagged with fillvalue + logical :: flag_xyfill = .false. + ! is_succol: .true. iff field output as subcol + logical :: is_subcol = .false. + ! mdims: indicies into hist_coords list + integer, pointer :: mdims(:) => NULL() + ! file_shape: shape of field on file + integer, pointer :: file_shape(:) => NULL() + ! field_shape: shape of field on file + integer, pointer :: field_shape(:) => NULL() + ! fillvalue: fillvalue for this variable + real(r8) :: fillvalue = hist_default_fillvalue + ! decomp_type: type of decomposition (e.g., physics or dynamics) + integer :: decomp_type + ! meridional and zonal complements are for fields defined as part of a + ! 2-D vector. These IDs are used to facilitate interpolated history output + ! At most one of these will be a positive field ID. + integer :: meridional_complement ! meridional field id or -1 + integer :: zonal_complement ! zonal field id or -1 + + character(len=max_fieldname_len) :: name ! field name + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + character(len=3) :: mixing_ratio ! 'dry' or 'wet' + character(len=max_chars) :: sampling_seq ! sampling sequence - if not every timestep, how often field is sampled + ! (i.e., how often "outfld" is called): every other; only during LW/SW + ! radiation calcs; etc. + character(len=max_chars) :: cell_methods ! optional cell_methods attribute + contains + procedure :: get_shape => field_info_get_shape + procedure :: get_bounds => field_info_get_bounds + procedure :: get_dims_2d => field_info_get_dims_2d + procedure :: get_dims_3d => field_info_get_dims_3d + generic :: get_dims => get_dims_2d, get_dims_3d + end type field_info + + + + !--------------------------------------------------------------------------- + ! + ! hentry: elements of an entry in the list of active fields on a single + ! history file + ! nacs is an accumulation counter which normally counts an entire + ! chunk (physics) or block (dynamics) as accumulated as a single + ! entity. The per-chunk counting avoids counting multiple outfld + ! calls as multiple accumulations. Only the value of the first chunk + ! or block is written to or read from a history restart file. + ! For certain actions (e.g., only accumulating on + ! non-fillvalue or accumulating based on local time), nacs has an + ! entry for every column. + ! nacs does not keep track of levels + ! + !--------------------------------------------------------------------------- + type, public:: hentry + type (field_info) :: field ! field information + character(len=1) :: avgflag ! averaging flag + character(len=max_chars) :: time_op ! time operator (e.g. max, min, avg) + + integer :: hwrt_prec ! history output precision + real(r8), pointer :: hbuf(:,:,:) => NULL() + real(r8), pointer :: sbuf(:,:,:) => NULL() ! for standard deviation + type(var_desc_t), pointer :: varid(:) => NULL() ! variable ids + integer, pointer :: nacs(:,:) => NULL() ! accumulation counter + type(var_desc_t), pointer :: nacs_varid => NULL() + type(var_desc_t), pointer :: sbuf_varid => NULL() + end type hentry + + !--------------------------------------------------------------------------- + ! + ! active_entry: derived type containing information for a history tape + ! + !--------------------------------------------------------------------------- + type, public:: active_entry + + type(hentry), pointer :: hlist(:) + + integer, pointer :: grid_ids(:) => NULL() + type(history_patch_t), pointer :: patches(:) => NULL() + + ! + ! PIO ids + ! + + type(file_desc_t) :: File ! PIO file id + + type(var_desc_t) :: mdtid ! varid for timestep + type(var_desc_t) :: ndbaseid ! varid for base day + type(var_desc_t) :: nsbaseid ! varid for base seconds of base day + type(var_desc_t) :: nbdateid ! varid for base date + type(var_desc_t) :: nbsecid ! varid for base seconds of base date + type(var_desc_t) :: ndcurid ! varid for current day + type(var_desc_t) :: nscurid ! varid for current seconds of current day + type(var_desc_t) :: dateid ! varid for current date + type(var_desc_t) :: co2vmrid ! varid for co2 volume mixing ratio + type(var_desc_t) :: ch4vmrid ! varid for ch4 volume mixing ratio + type(var_desc_t) :: n2ovmrid ! varid for n2o volume mixing ratio + type(var_desc_t) :: f11vmrid ! varid for f11 volume mixing ratio + type(var_desc_t) :: f12vmrid ! varid for f12 volume mixing ratio + type(var_desc_t) :: sol_tsiid ! varid for total solar irradiance (W/m2) + type(var_desc_t) :: datesecid ! varid for curent seconds of current date +#if ( defined BFB_CAM_SCAM_IOP ) + type(var_desc_t) :: bdateid ! varid for base date + type(var_desc_t) :: tsecid ! varid for curent seconds of current date +#endif + type(var_desc_t) :: nstephid ! varid for current timestep + type(var_desc_t) :: timeid ! varid for time + type(var_desc_t) :: tbndid ! varid for time_bnds + type(var_desc_t) :: date_writtenid ! varid for date time sample written + type(var_desc_t) :: time_writtenid ! varid for time time sample written + type(var_desc_t) :: f107id ! varid for f107 + type(var_desc_t) :: f107aid ! varid for f107a + type(var_desc_t) :: f107pid ! varid for f107p + type(var_desc_t) :: kpid ! varid for kp + type(var_desc_t) :: apid ! varid for ap + type(var_desc_t) :: byimfid ! varid IMF BY + type(var_desc_t) :: bzimfid ! varid IMF BZ + type(var_desc_t) :: swvelid ! varid solar wind velocity + type(var_desc_t) :: swdenid ! varid solar wind density + type(var_desc_t) :: colat_crit1_id ! critical colatitude + type(var_desc_t) :: colat_crit2_id ! critical colatitude + + end type active_entry + + !--------------------------------------------------------------------------- + ! + ! formula_terms_t: Information for formula terms (CF convention) variables + ! Used to add a formula-terms variable to the history file + ! Also adds a string, ': ' to the parent + ! mdim's 'formula_terms' attribute. + ! + !--------------------------------------------------------------------------- + type, public :: formula_terms_t + character(len=max_fieldname_len) :: a_name = '' ! 'A' term variable name + character(len=max_string_len) :: a_long_name = '' ! 'A' long name + real(r8), pointer :: a_values(:) => null() ! 'A' variable values + character(len=max_fieldname_len) :: b_name = '' ! 'B' term variable name + character(len=max_string_len) :: b_long_name = '' ! 'B' long name + real(r8), pointer :: b_values(:) => null() ! 'B' variable values + character(len=max_fieldname_len) :: p0_name = '' ! 'p0' term variable name + character(len=max_string_len) :: p0_long_name = '' ! 'p0' long name + character(len=max_chars) :: p0_units = '' ! 'p0' variable units + real(r8) :: p0_value = fillvalue ! 'p0' variable values + character(len=max_fieldname_len) :: ps_name = '' ! 'ps' term variable name + end type formula_terms_t + + !--------------------------------------------------------------------------- + ! + ! hist_coord_t: Information for history variable dimension attributes + ! + !--------------------------------------------------------------------------- + type, public :: hist_coord_t + character(len=max_hcoordname_len) :: name = '' ! coordinate name + integer :: dimsize = 0 ! size of dimension + character(len=max_hcoordname_len) :: dimname = '' ! optional dimension name + character(len=max_chars) :: long_name = '' ! 'long_name' attribute + character(len=max_chars) :: units = '' ! 'units' attribute + character(len=max_chars) :: bounds_name = '' ! 'bounds' attribute (& name of bounds variable) + character(len=max_chars) :: standard_name = ''! 'standard_name' attribute + character(len=4) :: positive = '' ! 'positive' attribute ('up' or 'down') + integer, pointer :: integer_values(:) => null() ! dim values if integral + real(r8), pointer :: real_values(:) => null() ! dim values if real + real(r8), pointer :: bounds(:,:) => null() ! dim bounds + type(formula_terms_t) :: formula_terms ! vars for formula terms + logical :: integer_dim ! .true. iff dim has integral values + logical :: vertical_coord ! .true. iff dim is vertical + end type hist_coord_t + + ! Some parameters for use with interpolated output namelist items + integer, parameter, public :: interp_type_native = 0 + integer, parameter, public :: interp_type_bilinear = 1 + integer, parameter, public :: interp_gridtype_equal_poles = 1 + integer, parameter, public :: interp_gridtype_gauss = 2 + integer, parameter, public :: interp_gridtype_equal_nopoles = 3 + + !--------------------------------------------------------------------------- + ! + ! hist_interp_info_t: Information for lat/lon interpolated history output + ! + !--------------------------------------------------------------------------- + type, public :: hist_interp_info_t + ! store the lat-lon grid information + character(len=28) :: gridname = '' + integer :: grid_id = -1 + ! gridtype = 1 equally spaced, including poles (FV scalars output grid) + ! gridtype = 2 Gauss grid (CAM Eulerian) + ! gridtype = 3 equally spaced, no poles (FV staggered velocity) + integer :: interp_gridtype = interp_gridtype_equal_poles + ! interpolate_type = 0: native high order interpolation + ! interpolate_type = 1: bilinear interpolation + integer :: interp_type = interp_type_bilinear + integer :: interp_nlat = 0 + integer :: interp_nlon = 0 + real(r8), pointer :: interp_lat(:) => NULL() + real(r8), pointer :: interp_lon(:) => NULL() + real(r8), pointer :: interp_gweight(:) => NULL() + contains + procedure :: reset => interp_reset + end type hist_interp_info_t + + !! Coordinate variables + integer, public :: registeredmdims = 0 + integer, public :: maxvarmdims = 1 + character(len=9), parameter, public :: mdim_var_name = 'mdimnames' + integer, parameter :: maxmdims = 25 ! arbitrary limit + type(hist_coord_t), public :: hist_coords(maxmdims) + + public :: add_hist_coord, add_vert_coord + public :: write_hist_coord_attrs, write_hist_coord_vars + public :: lookup_hist_coord_indices, hist_coord_find_levels + public :: get_hist_coord_index, hist_coord_name, hist_coord_size + public :: sec2hms, date2yyyymmdd + + interface add_hist_coord + module procedure add_hist_coord_regonly + module procedure add_hist_coord_int + module procedure add_hist_coord_r8 + end interface add_hist_coord + + interface hist_coord_size + module procedure hist_coord_size_char + module procedure hist_coord_size_int + end interface hist_coord_size + + interface assignment(=) + module procedure field_copy + module procedure formula_terms_copy + end interface assignment(=) + + interface check_hist_coord + ! NB: This is supposed to be a private interface + ! check_hist_coord: returns 0 if is not registered as an mdim + ! returns i if is registered with compatible values + ! calls endrun if is registered with incompatible values + ! Versions without the argument return .true. or .false. + module procedure check_hist_coord_char + module procedure check_hist_coord_int + module procedure check_hist_coord_int1 + module procedure check_hist_coord_r8 + module procedure check_hist_coord_r81 + module procedure check_hist_coord_r82 + module procedure check_hist_coord_ft + module procedure check_hist_coord_all + end interface check_hist_coord + + !!--------------------------------------------------------------------------- + +CONTAINS + + subroutine interp_reset(this) + type(hist_interp_info_t), intent(inout) :: this + + character(len=28) :: gridname = '' + integer :: grid_id = -1 + ! gridtype = 1 equally spaced, including poles (FV scalars output grid) + ! gridtype = 2 Gauss grid (CAM Eulerian) + ! gridtype = 3 equally spaced, no poles (FV staggered velocity) + integer :: interp_gridtype = interp_gridtype_equal_poles + ! interpolate_type = 0: native high order interpolation + ! interpolate_type = 1: bilinear interpolation + integer :: interp_type = interp_type_bilinear + integer :: interp_nlat = 0 + integer :: interp_nlon = 0 + real(r8), pointer :: interp_lat(:) => NULL() + real(r8), pointer :: interp_lon(:) => NULL() + real(r8), pointer :: interp_gweight(:) => NULL() + end subroutine interp_reset + + subroutine dim_index_2d_dim_sizes_2d(this, dim1, dim2) + + ! Dummy arguments + class(dim_index_2d) :: this + integer, intent(out) :: dim1 + integer, intent(out) :: dim2 + + dim1 = MAX(0, this%end1 - this%beg1 + 1) + dim2 = MAX(0, this%end2 - this%beg2 + 1) + + end subroutine dim_index_2d_dim_sizes_2d + + subroutine dim_index_2d_dim_size_arr(this, dims) + + ! Dummy arguments + class(dim_index_2d) :: this + integer, intent(out) :: dims(:) + + if (size(dims) < 2) then + call endrun('dim_index_2d_dim_sizes: dims must have at least two elements') + end if + + call this%dim_sizes(dims(1), dims(2)) + + end subroutine dim_index_2d_dim_size_arr + + subroutine dim_index_3d_dim_sizes_3d(this, dim1, dim2, dim3) + + ! Dummy arguments + class(dim_index_3d) :: this + integer, intent(out) :: dim1 + integer, intent(out) :: dim2 + integer, intent(out) :: dim3 + + dim1 = MAX(0, this%end1 - this%beg1 + 1) + dim2 = MAX(0, this%end2 - this%beg2 + 1) + dim3 = MAX(0, this%end3 - this%beg3 + 1) + + end subroutine dim_index_3d_dim_sizes_3d + + subroutine dim_index_3d_dim_size_arr(this, dims) + + ! Dummy arguments + class(dim_index_3d) :: this + integer, intent(out) :: dims(:) + + if (size(dims) < 3) then + call endrun('dim_index_3d_dim_sizes: dims must have at least three elements') + end if + + call this%dim_sizes(dims(1), dims(2), dims(3)) + + end subroutine dim_index_3d_dim_size_arr + + ! field_info_get_dims_2d: Retrieve bounds for stepping through a chunk + type(dim_index_2d) function field_info_get_dims_2d(this, col) result(dims) + use cam_grid_support, only: cam_grid_get_block_count + + ! Dummy argument + class(field_info) :: this + integer, intent(in) :: col + + ! Local variable + integer :: endi + + if (this%colperchunk) then + endi = this%begdim1 + cam_grid_get_block_count(this%decomp_type, col) - 1 + dims = dim_index_2d(this%begdim1, endi, this%begdim2, this%enddim2) + else + dims = dim_index_2d(this%begdim1, this%enddim1, this%begdim2, this%enddim2) + end if + end function field_info_get_dims_2d + + ! field_info_get_dims_3d: Retrieve grid decomp bounds + type(dim_index_3d) function field_info_get_dims_3d(this) result(dims) + + ! Dummy argument + class(field_info) :: this + + dims = dim_index_3d(this%begdim1, this%enddim1, this%begdim2, this%enddim2,& + this%begdim3, this%enddim3) + + end function field_info_get_dims_3d + + ! field_info_get_shape: Return a pointer to the field's global shape. + ! Calculate it first if necessary + subroutine field_info_get_shape(this, shape_out, rank_out) + use cam_grid_support, only: cam_grid_dimensions + + ! Dummy arguments + class(field_info) :: this + integer, intent(out) :: shape_out(:) + integer, intent(out) :: rank_out + + ! Local arguments + integer :: rank, i, pos + integer :: gdims(2) + + if (.not. associated(this%shape)) then + ! Calculate field's global shape + call cam_grid_dimensions(this%decomp_type, gdims, rank) + pos = rank + if (associated(this%mdims)) then + rank = rank + size(this%mdims) + end if + allocate(this%shape(rank)) + this%shape(1:pos) = gdims(1:pos) + if (rank > pos) then + do i = 1, size(this%mdims) + pos = pos + 1 + this%shape(pos) = hist_coords(this%mdims(i))%dimsize + end do + end if + end if + + rank_out = size(this%shape) + + if (size(shape_out) < rank_out) then + call endrun('field_info_get_shape: shape_out too small') + end if + + shape_out(1:rank_out) = this%shape(1:rank_out) + if (size(shape_out) > rank_out) then + shape_out(rank_out+1:) = 1 + end if + + end subroutine field_info_get_shape + + subroutine field_info_get_bounds(this, dim, dbeg, dend) + + ! Dummy arguments + class(field_info) :: this + integer, intent(in) :: dim + integer, intent(out) :: dbeg + integer, intent(out) :: dend + + select case(dim) + case (1) + dbeg = this%dbegdim1 + dend select= this%enddim1 + case (2) + dbeg = this%dbegdim2 + dend = this%enddim2 + case (3) + dbeg = this%dbegdim3 + dend = this%enddim3 + case default + call endrun('field_info_get_bounds: dim must be 1, 2, or 3') + end select + + end subroutine field_info_get_bounds + + ! history_patch_write_attrs: Define coordinate variables and attributes + ! for a patch + subroutine history_patch_write_attrs(this, File) + use cam_grid_support, only: cam_grid_is_unstructured + use pio, only: file_desc_t, var_desc_t, pio_put_att + use pio, only: pio_double + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + use cam_pio_utils, only: cam_pio_handle_error + + ! Dummy arguments + class(history_patch_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + + ! Local variable + type(cam_grid_patch_t), pointer :: patchptr + type(var_desc_t), pointer :: vardesc_lat => NULL() + type(var_desc_t), pointer :: vardesc_lon => NULL() + character(len=128) :: errormsg + character(len=max_chars) :: lat_name + character(len=max_chars) :: lon_name + character(len=max_chars) :: col_name + character(len=max_chars) :: temp_str + integer :: dimid1, dimid2 ! PIO dim IDs + integer :: num_patches + integer :: temp1, temp2 + integer :: latid, lonid ! Coordinate dims + integer :: i, ierr + logical :: col_ only + logical :: unstruct + character(len=*), parameter :: subname = 'history_patch_write_attrs' + + num_patches = size(this%patches) + if (associated(this%header_info)) then + ! Make sure header_info is the right size + if (size(this%header_info) /= num_patches) then + write(errormsg, '(2a,2(i0,a))') 'Size mismatch between ', & + 'header_info (', size(this%header_info), ') and patches (', & + num_patches, ')' + call endrun(subname//': '//trim(errormsg)) + end if + else + allocate(this%header_info(num_patches)) + end if + + ! Write attributes for each patch + do i = 1, num_patches + patchptr => this%patches(i) + call this%header_info(i)%set_gridid(patchptr%gridid()) + unstruct = cam_grid_is_unstructured(patchptr%gridid()) + ! What are the dimension(s) for this patch? + col_only = this%collected_output + if (num_patches == 1) then + ! Backwards compatibility + if (unstruct .or. col_only) then + col_name = 'ncol' + else + col_name = '' + end if + lat_name = 'lat' + lon_name = 'lon' + else + call patchptr%get_axis_names(lat_name, lon_name, col_name, col_only) + end if + ! Define the dimensions (latx/lonx or ncolx) + ! col_name is set for unstructured output or collected columns (ncolx) + if (len_trim(col_name) > 0) then + call patchptr%get_global_size(gsize=temp1) + if (temp1 <= 0) then + call endrun(subname//': col dimsize must be positive') + end if + if (unstruct .and. (.not. col_only)) then + ! For the case of unstructured output without collected column + ! output, we need to make sure that the ncolx dimension is unique + col_name = trim(col_name)//'_'//trim(this%lon_axis_name)// & + '_'//trim(this%lat_axis_name) + end if + call cam_pio_def_dim(File, trim(col_name), temp1, dimid1, & + existOK=.false.) + call this%header_info(i)%set_hdims(dimid1) + latid = dimid1 + lonid = dimid1 + else + lat_name = trim(lat_name)//'_'//trim(this%lat_axis_name) + call patchptr%get_global_size(temp1, temp2) + if (temp1 <= 0) then + call endrun(subname//': lat dimsize must be positive') + end if + call cam_pio_def_dim(File, trim(lat_name), temp1, dimid1, & + existOK=.true.) + latid = dimid1 + lon_name = trim(lon_name)//'_'//trim(this%lon_axis_name) + if (temp2 <= 0) then + call endrun(subname//': lon dimsize must be positive') + end if + call cam_pio_def_dim(File, trim(lon_name), temp2, dimid2, & + existOK=.true.) + lonid = dimid2 + call this%header_info(i)%set_hdims(lonid, latid) + end if + !! Define the latx (coordinate) variable + if (unstruct .and. (.not. col_only)) then + ! We need to make sure the latx name is unique + lat_name = trim(lat_name)//'_'//trim(this%lon_axis_name)//'_'// & + trim(this%lat_axis_name) + end if + allocate(vardesc_lat) + call cam_pio_def_var(File, trim(lat_name), pio_double, (/latid/), & + vardesc_lat, existOK=.true.) + ! Coordinate attributes + call patchptr%get_coord_long_name('lat', temp_str) + if (len_trim(temp_str) > 0) then + ierr = pio_put_att(File, vardesc_lat, 'long_name', trim(temp_str)) + call cam_pio_handle_error(ierr, subname// & + ': Unable to define long_name') + end if + call patchptr%get_coord_units('lat', temp_str) + if (len_trim(temp_str) > 0) then + ierr = pio_put_att(File, vardesc_lat, 'units', trim(temp_str)) + call cam_pio_handle_error(ierr, subname//': Unable to define units') + end if + !! Define the lonx (coordinate) variable + if (unstruct .and. (.not. col_only)) then + ! We need to make sure the lonx name is unique + lon_name = trim(lon_name)//'_'//trim(this%lon_axis_name)//'_'// & + trim(this%lat_axis_name) + end if + allocate(vardesc_lon) + call cam_pio_def_var(File, trim(lon_name), pio_double, (/lonid/), & + vardesc_lon, existOK=.true.) + ! Coordinate attributes + call patchptr%get_coord_long_name('lon', temp_str) + if (len_trim(temp_str) > 0) then + ierr = pio_put_att(File, vardesc_lon, 'long_name', trim(temp_str)) + call cam_pio_handle_error(ierr, subname// & + ': Unable to define long_name') + end if + call patchptr%get_coord_units('lon', temp_str) + if (len_trim(temp_str) > 0) then + ierr = pio_put_att(File, vardesc_lon, 'units', trim(temp_str)) + call cam_pio_handle_error(ierr, subname//': Unable to define units') + end if + call this%header_info(i)%set_varids(vardesc_lon, vardesc_lat) + nullify(vardesc_lat, vardesc_lon) ! They belong to the header_info now + end do + + end subroutine history_patch_write_attrs + + ! history_patch_write_vals: Write coordinate variable values for a patch + subroutine history_patch_write_vals(this, File) + use pio, only: file_desc_t, var_desc_t + + ! Dummy arguments + class(history_patch_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + + ! Local variable + type(cam_grid_patch_t), pointer :: patchptr + type(var_desc_t), pointer :: vardesc => NULL() ! PIO var desc + character(len=128) :: errormsg + character(len=max_chars) :: lat_name + character(len=max_chars) :: lon_name + character(len=max_chars) :: col_name + character(len=max_chars) :: temp_str + integer :: dimid ! PIO dimension ID + integer :: num_patches + integer :: temp1, temp2 + integer :: latid, lonid ! Coordinate dims + integer :: i + logical :: col_ only + + num_patches = size(this%patches) + if (.not. associated(this%header_info)) then + ! We need this for dim and coord variable descriptors + write(errormsg, '(2a)') 'No header info for ', & + trim(this%namelist_entry) + call endrun('history_patch_write_vals: '//trim(errormsg)) + end if + + ! Write attributes for each patch + do i = 1, num_patches + patchptr => this%patches(i) + ! Write the coordinate variables (or just lat/lon for column output) + call patchptr%write_coord_vals(File, this%header_info(i)) + end do + + end subroutine history_patch_write_vals + + ! history_patch_field_name: Add patch description to field name + subroutine history_patch_field_name(this, name) + ! Dummy arguments + class(history_patch_t) :: this + character(len=*), intent(inout) :: name + + if (.not. this%collected_output) then + ! Add patch description info to the variable name + name = trim(name)//'_'//trim(this%lon_axis_name)//'_'// & + trim(this%lat_axis_name) + end if + end subroutine history_patch_field_name + + ! history_patch_num_hdims: Find the number of horizontal dimensions for + ! the indicated grid + integer function history_patch_num_hdims(this, gridid) + ! Dummy arguments + class(history_patch_t) :: this + integer, intent(in) :: gridid ! The field's grid + + ! Local variables + type(cam_grid_patch_t), pointer :: patchptr + character(len=128) :: errormsg + integer :: i + integer :: num_patches + + ! Basic sanity checks, is this patch OK? + num_patches = size(this%patches) + if (associated(this%header_info)) then + ! Make sure header_info is the right size + if (size(this%header_info) /= num_patches) then + write(errormsg, '(a,2(i0,a))') & + 'Size mismatch between header_info (', & + size(this%header_info), ') and patches (', num_patches, ')' + call endrun('history_patch_num_hdims: '//trim(errormsg)) + end if + else + write(errormsg, *) 'No header info for patch, ', & + trim(this%namelist_entry) + call endrun('history_patch_num_hdims: '//trim(errormsg)) + end if + + ! Find the correct patch by matching grid ID + history_patch_num_hdims = -1 + do i = 1, num_patches + patchptr => this%patches(i) + if (patchptr%gridid() == gridid) then + ! This is the right patch, set the return val and quit loop + history_patch_num_hdims = this%header_info(i)%num_hdims() + exit + else if (i >= num_patches) then + write(errormsg, '(3a,i0)') 'No grid found for patch, ', & + trim(this%namelist_entry), '. Was looking for decomp ', gridid + call endrun('history_patch_num_hdims: '//errormsg) + ! No else needed + end if + end do + if (history_patch_num_hdims <= 0) then + write(errormsg, '(2a,2(a,i0))') 'INTERNAL: No grid patch for ', & + trim(this%namelist_entry), ', num_patches = ',num_patches, & + ', gridid = ', gridid + call endrun('history_patch_num_hdims: '//errormsg) + end if + + end function history_patch_num_hdims + + ! history_patch_get_var_data: Calculate data relevant to history variable + ! on a patch by substituting patch dimension ids for the horiz. ids + ! and adding patch information to the variable name + subroutine history_patch_get_var_data(this, name, dimids, gridid) + ! Dummy arguments + class(history_patch_t) :: this + character(len=*), intent(inout) :: name + integer, intent(inout) :: dimids(:) ! Grid dimids + integer, intent(in) :: gridid ! The field's grid + + ! Local variables + type(cam_grid_patch_t), pointer :: patchptr + type (cam_grid_header_info_t), pointer :: histptr + character(len=128) :: errormsg + integer :: num_patches + integer :: i + + ! Basic sanity checks, is this patch OK? + num_patches = size(this%patches) + if (associated(this%header_info)) then + ! Make sure header_info is the right size + if (size(this%header_info) /= num_patches) then + write(errormsg, '(a,2(i0,a))') & + 'Size mismatch between header_info (', & + size(this%header_info), ') and patches (', num_patches, ')' + call endrun('history_patch_get_var_data: '//trim(errormsg)) + end if + else + write(errormsg, *) 'No header info for patch, ', & + trim(this%namelist_entry) + call endrun('history_patch_get_var_data: '//trim(errormsg)) + end if + + ! Find the correct patch by matching grid ID + do i = 1, num_patches + patchptr => this%patches(i) + if (patchptr%gridid() == gridid) then + ! This is the right patch, quit loop + histptr => this%header_info(i) + exit + else if (i >= num_patches) then + write(errormsg, '(3a,i0)') 'No grid found for patch, ', & + trim(this%namelist_entry), '. Was looking for decomp ', gridid + call endrun('history_patch_get_var_data: '//errormsg) + ! No else needed + end if + end do + + ! We have the correct patch, replace the horizontal dimension ids + do i = 1, histptr%num_hdims() + dimids(i) = histptr%get_hdimid(i) + end do + ! Re-define the variable name + call this%field_name(name) + + end subroutine history_patch_get_var_data + + subroutine history_patch_compact(this) + + ! Dummy arguments + class(history_patch_t) :: this + + ! Local variables + integer :: num_patches + integer :: i + + num_patches = size(this%patches) + + ! Find the correct patch by matching grid ID + do i = 1, num_patches + call this%patches(i)%compact(this%collected_output) + end do + + end subroutine history_patch_compact + + subroutine history_patch_write_var(this, File, gridid, adims, dtype, & + hbuf, varid) + use pio, only: file_desc_t, var_desc_t, io_desc_t + use pio, only: pio_write_darray + use cam_pio_utils, only: cam_pio_handle_error, cam_pio_var_info + + ! Dummy arguments + class(history_patch_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: gridid + integer, intent(in) :: adims(:) + integer, intent(in) :: dtype + real(r8), intent(in) :: hbuf(:,:,:) + type(var_desc_t), pointer :: varid + + ! Local variables + type(cam_grid_patch_t), pointer :: patchptr + character(len=128) :: errormsg + integer :: num_patches + integer :: i, idx + integer :: uid ! unlimited dim ID + type(io_desc_t), pointer :: iodesc + integer :: ierr, nfdims + integer :: fdimlens(7), dimids(7) + character(len=*), parameter :: subname = 'history_patch_write_var: ' + + num_patches = size(this%patches) + + ! Find the correct patch by matching grid ID + do i = 1, num_patches + patchptr => this%patches(i) + if (patchptr%gridid() == gridid) then + ! This is the right patch, quit loop + exit + else if (i >= num_patches) then + write(errormsg, '(3a,i0)') 'No grid found for patch, ', & + trim(this%namelist_entry), '. Was looking for decomp ', gridid + call endrun(subname//trim(errormsg)) + ! No else needed + end if + end do + + ! We have the right grid, write the hbuf + call cam_pio_var_info(File, varid, nfdims, dimids, fdimlens, & + unlimDimID=uid) + idx = 1 + do i = 1, nfdims + if (i > idx) then + dimids(idx) = dimids(i) + end if + if (dimids(i) /= uid) then + idx = idx + 1 + end if + end do + nfdims = nfdims - COUNT(dimids(1:nfdims) == uid) + call patchptr%get_decomp(adims, fdimlens(1:nfdims), dtype, iodesc) + if (size(adims) == 2) then + call pio_write_darray(File, varid, iodesc, hbuf(:,1,:), ierr) + else if (size(adims) == 3) then + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + else + call endrun(subname//"adims must be rank 2 or 3") + end if + call cam_pio_handle_error(ierr, subname//'Error writing variable') + + end subroutine history_patch_write_var + + subroutine history_patch_active_cols(this, gridid, lchnk, active) + ! Dummy arguments + class(history_patch_t) :: this + integer, intent(in) :: gridid ! desired grid + integer, intent(in) :: lchnk ! chunk or block number + logical, intent(out) :: active(:) + + ! Local variables + type(cam_grid_patch_t), pointer :: patchptr + character(len=128) :: errormsg + integer :: num_patches + integer :: i + + num_patches = size(this%patches) + + ! Find the correct patch by matching grid ID + do i = 1, num_patches + patchptr => this%patches(i) + if (patchptr%gridid() == gridid) then + ! This is the right patch, quit loop + exit + else if (i >= num_patches) then + write(errormsg, '(3a,i0)') 'No grid found for patch, ', & + trim(this%namelist_entry), '. Was looking for decomp ', gridid + call endrun('history_patch_active_cols: '//errormsg) + ! No else needed + end if + end do + + ! If we get here, patchptr is the grid patch we want + call patchptr%active_cols(lchnk, active) + + end subroutine history_patch_active_cols + + subroutine history_patch_deallocate(this) + ! Dummy argument + class(history_patch_t) :: this + ! Local variable + integer :: i + + this%lon_axis_name = '' + this%lat_axis_name = '' + + if (associated(this%patches)) then + do i = 1, size(this%patches) + call this%patches(i)%deallocate() + end do + deallocate(this%patches) + nullify(this%patches) + end if + + if (associated(this%header_info)) then + do i = 1, size(this%header_info) + call this%header_info(i)%deallocate() + end do + deallocate(this%header_info) + nullify(this%header_info) + end if + + end subroutine history_patch_deallocate + + subroutine field_copy(f_out, f_in) + type(field_info), intent(in) :: f_in + type(field_info), intent(out) :: f_out + + f_out%flag_xyfill= f_in%flag_xyfill + f_out%is_subcol = f_in%is_subcol + f_out%fillvalue= f_in%fillvalue + f_out%numlev = f_in%numlev ! vertical dimension (.nc file and internal arr) + f_out%begdim1 = f_in%begdim1 ! on-node dim1 start index + f_out%enddim1 = f_in%enddim1 ! on-node dim1 end index + f_out%begdim2 = f_in%begdim2 ! on-node dim2 start index + f_out%enddim2 = f_in%enddim2 ! on-node dim2 end index + f_out%begdim3 = f_in%begdim3 ! on-node chunk or lat start index + f_out%enddim3 = f_in%enddim3 ! on-node chunk or lat end index + f_out%decomp_type = f_in%decomp_type ! type of decomposition (physics or dynamics) + + f_out%meridional_complement = f_in%meridional_complement ! id or -1 + f_out%zonal_complement = f_in%zonal_complement ! id or -1 + + f_out%name = f_in%name ! field name + f_out%long_name = f_in%long_name ! long name + f_out%units = f_in%units ! units + f_out%sampling_seq = f_in%sampling_seq ! sampling sequence - if not every timestep, how often field is sampled + f_out%cell_methods = f_in%cell_methods + + if(associated(f_in%mdims)) then + f_out%mdims=>f_in%mdims + else + nullify(f_out%mdims) + end if + + end subroutine field_copy + + subroutine formula_terms_copy(f_out, f_in) + type(formula_terms_t), intent(in) :: f_in + type(formula_terms_t), intent(out) :: f_out + + f_out%a_name = f_in%a_name + f_out%a_long_name = f_in%a_long_name + f_out%a_values => f_in%a_values + f_out%b_name = f_in%b_name + f_out%b_long_name = f_in%b_long_name + f_out%b_values => f_in%b_values + f_out%p0_name = f_in%p0_name + f_out%p0_long_name = f_in%p0_long_name + f_out%p0_units = f_in%p0_units + f_out%p0_value = f_in%p0_value + f_out%ps_name = f_in%ps_name + end subroutine formula_terms_copy + + integer function get_hist_coord_index(mdimname) + ! Input variables + character(len=*), intent(in) :: mdimname + ! Local variable + integer :: i + + get_hist_coord_index = -1 + do i = 1, registeredmdims + if(trim(mdimname) == trim(hist_coords(i)%name)) then + get_hist_coord_index = i + exit + end if + end do + + end function get_hist_coord_index + + character(len=max_hcoordname_len) function hist_coord_name(index) + ! Input variables + integer, intent(in) :: index + + if ((index > 0) .and. (index <= registeredmdims)) then + hist_coord_name = hist_coords(index)%name + else + call endrun('hist_coord_name: index out of range') + end if + + end function hist_coord_name + + integer function hist_coord_size_int(index) + ! Input variables + integer, intent(in) :: index + + if (index > 0) then + hist_coord_size_int = hist_coords(index)%dimsize + else + hist_coord_size_int = -1 + end if + + end function hist_coord_size_int + + integer function hist_coord_size_char(mdimname) + ! Input variables + character(len=*), intent(in) :: mdimname + ! Local variable + integer :: i + + i = get_hist_coord_index(mdimname) + hist_coord_size_char = hist_coord_size(i) + + end function hist_coord_size_char + + ! Functions to check consistent term definition for hist coords + logical function check_hist_coord_char(defined, input) + + ! Input variables + character(len=*), intent(in) :: defined + character(len=*), intent(in), optional :: input + + if (len_trim(defined) == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_char = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_char = (trim(input) == trim(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_char = .false. + end if + end function check_hist_coord_char + + logical function check_hist_coord_int(defined, input) + + ! Input variables + integer, intent(in) :: defined + integer, intent(in), optional :: input + + if (defined == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_int = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_int = (input == defined) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_int = .false. + end if + end function check_hist_coord_int + + logical function check_hist_coord_int1(defined, input) + + ! Input variables + integer, pointer :: defined(:) + integer, intent(in), optional :: input(:) + + ! Local variables + integer :: i + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_int1 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_int1 = (size(input) == size(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_int1 = .false. + end if + if (check_hist_coord_int1 .and. associated(defined)) then + ! Need to check the values + do i = 1, size(defined) + if (defined(i) /= input(i)) then + check_hist_coord_int1 = .false. + exit + end if + end do + end if + end function check_hist_coord_int1 + + logical function check_hist_coord_r8(defined, input) + + ! Input variables + real(r8), intent(in) :: defined + real(r8), intent(in), optional :: input + + if (defined == fillvalue) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r8 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r8 = (input == defined) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r8 = .false. + end if + end function check_hist_coord_r8 + + logical function check_hist_coord_r81(defined, input) + + ! Input variables + real(r8), pointer :: defined(:) + real(r8), intent(in), optional :: input(:) + + ! Local variables + integer :: i + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r81 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r81 = (size(input) == size(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r81 = .false. + end if + if (check_hist_coord_r81 .and. associated(defined)) then + ! Need to check the values + do i = 1, size(defined) + if (defined(i) /= input(i)) then + check_hist_coord_r81 = .false. + exit + end if + end do + end if + end function check_hist_coord_r81 + + logical function check_hist_coord_r82(defined, input) + + ! Input variables + real(r8), pointer :: defined(:,:) + real(r8), intent(in), optional :: input(:,:) + + ! Local variables + integer :: i, j + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r82 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r82 = ((size(input, 1) == size(defined, 1)) .and. & + (size(input, 2) == size(defined, 2))) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r82 = .false. + end if + if (check_hist_coord_r82 .and. associated(defined)) then + ! Need to check the values + do j = 1, size(defined, 2) + do i = 1, size(defined, 1) + if (defined(i, j) /= input(i, j)) then + check_hist_coord_r82 = .false. + exit + end if + end do + end do + end if + end function check_hist_coord_r82 + + logical function check_hist_coord_ft(defined, input) + + ! Input variables + type(formula_terms_t), intent(in) :: defined + type(formula_terms_t), intent(in), optional :: input + + ! We will assume that if formula_terms has been defined, a_name has a value + if (len_trim(defined%a_name) == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_ft = .true. + else if (present(input)) then + ! We have to match definitions + ! Need to check the values + check_hist_coord_ft = & + check_hist_coord(defined%a_name, input%a_name) .and. & + check_hist_coord(defined%a_long_name, input%a_long_name) .and. & + check_hist_coord(defined%a_values, input%a_values) .and. & + check_hist_coord(defined%b_name, input%b_name) .and. & + check_hist_coord(defined%b_long_name, input%b_long_name) .and. & + check_hist_coord(defined%b_values, input%b_values) .and. & + check_hist_coord(defined%p0_name, input%p0_name) .and. & + check_hist_coord(defined%p0_long_name, input%p0_long_name) .and. & + check_hist_coord(defined%p0_units, input%p0_units) .and. & + check_hist_coord(defined%p0_value, input%p0_value) .and. & + check_hist_coord(defined%ps_name, input%ps_name) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_ft = .false. + end if + end function check_hist_coord_ft + + ! check_hist_coord: returns 0 if is not registered as a hist coord + ! returns i if is registered with compatible values + ! calls endrun if is registered with incompatible values + integer function check_hist_coord_all(name, vlen, long_name, units, bounds, & + i_values, r_values, bounds_name, positive, standard_name, formula_terms) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in), optional :: long_name + character(len=*), intent(in), optional :: units + character(len=*), intent(in), optional :: bounds_name + integer, intent(in), optional :: i_values(:) + real(r8), intent(in), optional :: r_values(:) + real(r8), intent(in), optional :: bounds(:,:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + type(formula_terms_t), intent(in), optional :: formula_terms + + ! Local variables + character(len=120) :: errormsg + integer :: i + + i = get_hist_coord_index(trim(name)) + ! If i > 0, this mdim has already been registered + if (i > 0) then + check_hist_coord_all = i + if (.not. check_hist_coord(hist_coords(i)%dimsize, vlen)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, '//trim(name)//' with incompatible size' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%long_name, long_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different long_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%units, units)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different units' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%bounds_name, bounds_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different bounds_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%standard_name, standard_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different standard_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%positive, positive)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different value of positive' + call endrun(errormsg) + end if + ! Since the integer_dim defaults to .true., double check which to check + if ((.not. hist_coords(i)%integer_dim) .or. & + associated(hist_coords(i)%real_values)) then + if (.not. check_hist_coord(hist_coords(i)%real_values, r_values)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values' + call endrun(errormsg) + else if (present(i_values)) then + write(errormsg, *) 'ERROR: Attempt to register integer values for real dimension' + call endrun(errormsg) + end if + else + if (.not. check_hist_coord(hist_coords(i)%integer_values, i_values)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values' + call endrun(errormsg) + else if (present(i_values) .and. present(r_values)) then + write(errormsg, *) 'ERROR: Attempt to register real values for integer dimension' + call endrun(errormsg) + end if + end if + if (.not. check_hist_coord(hist_coords(i)%bounds, bounds)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different bounds' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%formula_terms, formula_terms)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different formula_terms' + call endrun(errormsg) + end if + else + check_hist_coord_all = 0 + end if + end function check_hist_coord_all + + subroutine add_hist_coord_regonly(name, index) + + ! Input variable + character(len=*), intent(in) :: name + integer, optional, intent(out) :: index + + ! Local variables + character(len=120) :: errormsg + integer :: i + + if ((trim(name) == trim(horiz_only)) .or. (len_trim(name) == 0)) then + call endrun('ADD_HIST_COORD: '//trim(name)//' is not a valid coordinate name') + end if + i = get_hist_coord_index(trim(name)) + ! If i > 0, this mdim has already been registered + if (i <= 0) then + registeredmdims = registeredmdims + 1 + if (registeredmdims > maxmdims) then + call endrun('Too many dimensions in add_hist_coord.') + end if + if (len_trim(name) > max_hcoordname_len) then + write(errormsg,'(a,i3,a)') 'History coord name exceeds the ', & + max_hcoordname_len, ' character length limit' + call endrun(errormsg) + end if + hist_coords(registeredmdims)%name = trim(name) + hist_coords(registeredmdims)%dimsize = 0 + hist_coords(registeredmdims)%long_name = '' + hist_coords(registeredmdims)%units = '' + hist_coords(registeredmdims)%integer_dim = .true. + hist_coords(registeredmdims)%positive = '' + hist_coords(registeredmdims)%standard_name = '' + if (present(index)) then + index = registeredmdims + end if + else + if (present(index)) then + index = i + end if + end if + + end subroutine add_hist_coord_regonly + + subroutine add_hist_coord_int(name, vlen, long_name, units, values, & + positive, standard_name, dimname) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in), optional :: units + integer, intent(in), target, optional :: values(:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + character(len=*), intent(in), optional :: dimname + + ! Local variables + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + i_values=values, positive=positive, standard_name=standard_name) + ! Register the name if necessary + if (i == 0) then + call add_hist_coord(trim(name), i) + ! if(masterproc) write(iulog,*) 'Registering hist coord',name,'(',i,') with length: ',vlen + end if + + ! Set the coord's values + hist_coords(i)%dimsize = vlen + if (len_trim(long_name) > max_chars) then + if(masterproc) then + write(iulog,*) 'WARNING: long_name for ',trim(name),' too long' + end if + end if + hist_coords(i)%long_name = trim(long_name) + if (present(units)) then + hist_coords(i)%units = trim(units) + else + hist_coords(i)%units = '' + end if + hist_coords(i)%integer_dim = .true. + if (present(values)) then + hist_coords(i)%integer_values => values + endif + if (present(positive)) then + hist_coords(i)%positive = trim(positive) + end if + if (present(standard_name)) then + hist_coords(i)%standard_name = trim(standard_name) + end if + hist_coords(i)%vertical_coord = .false. + if (present(dimname)) then + hist_coords(i)%dimname = trim(dimname) + else + hist_coords(i)%dimname = '' + end if + + end subroutine add_hist_coord_int + + subroutine add_hist_coord_r8(name, vlen, long_name, units, values, & + bounds_name, bounds, positive, standard_name, vertical_coord, dimname) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + real(r8), intent(in), target :: values(:) + character(len=*), intent(in), optional :: bounds_name + real(r8), intent(in), target, optional :: bounds(:,:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + logical, intent(in), optional :: vertical_coord + character(len=*), intent(in), optional :: dimname + + ! Local variables + character(len=120) :: errormsg + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + r_values=values, positive=positive, standard_name=standard_name, & + bounds_name=bounds_name, bounds=bounds) + ! Register the name if necessary + if (i == 0) then + call add_hist_coord(trim(name), i) + ! if(masterproc) write(iulog,*) 'Registering hist coord',name,'(',i,') with length: ',vlen + end if + + ! Set the coord's size + hist_coords(i)%dimsize = vlen + if (len_trim(long_name) > max_chars) then + if(masterproc) then + write(iulog,*) 'WARNING: long_name for ',trim(name),' too long' + end if + end if + hist_coords(i)%long_name = trim(long_name) + if (len_trim(units) > 0) then + hist_coords(i)%units = trim(units) + else + hist_coords(i)%units = '1' + end if + hist_coords(i)%integer_dim = .false. + hist_coords(i)%real_values => values + if (present(positive)) then + hist_coords(i)%positive = trim(positive) + end if + if (present(standard_name)) then + hist_coords(i)%standard_name = trim(standard_name) + end if + if (present(bounds_name)) then + hist_coords(i)%bounds_name = trim(bounds_name) + if (.not. present(bounds)) then + write(errormsg,*) 'bounds must be present for ',trim(bounds_name) + call endrun(errormsg) + end if + hist_coords(i)%bounds => bounds + else if (present(bounds)) then + write(errormsg,*) 'bounds_name must be present for bounds values' + call endrun(errormsg) + else + hist_coords(i)%bounds_name = '' + end if + if (present(vertical_coord)) then + hist_coords(i)%vertical_coord = vertical_coord + else + hist_coords(i)%vertical_coord = .false. + end if + if (present(dimname)) then + hist_coords(i)%dimname = trim(dimname) + else + hist_coords(i)%dimname = '' + end if + + end subroutine add_hist_coord_r8 + + subroutine add_vert_coord(name, vlen, long_name, units, values, & + positive, standard_name, formula_terms) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + real(r8), intent(in), target :: values(:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + type(formula_terms_t), intent(in), optional :: formula_terms + + ! Local variable + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + r_values=values, positive=positive, standard_name=standard_name, & + formula_terms=formula_terms) + ! Register the name and hist_coord values if necessary + if (i == 0) then + call add_hist_coord(trim(name), vlen, long_name, units, values, & + positive=positive, standard_name=standard_name, & + vertical_coord=.true.) + i = get_hist_coord_index(trim(name)) + ! if(masterproc) write(iulog,*) 'Registering hist coord',name,'(',i,') with length: ',vlen + end if + + if (present(formula_terms)) then + hist_coords(i)%formula_terms = formula_terms + end if + + end subroutine add_vert_coord + + subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid) + use pio, only: file_desc_t, var_desc_t, pio_put_att, pio_noerr, & + pio_int, pio_double, pio_inq_varid, pio_def_var + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: mdimind ! Internal dim index + integer, intent(in) :: boundsdim ! Bounds dimension ID + logical, intent(in) :: dimonly ! No def_var if .true. + integer, optional, intent(out) :: mdimid + + ! Local variables + integer :: dimid ! PIO dimension ID + type(var_desc_t) :: vardesc ! PIO variable descriptor + character(len=120) :: errormsg + character(len=max_chars) :: formula_terms ! Constructed string + integer :: ierr + integer :: dtype + logical :: defvar ! True if var exists + + ! Create or check dimension for this coordinate + if (len_trim(hist_coords(mdimind)%dimname) > 0) then + ! Dim can already exist if different from coord name + call cam_pio_def_dim(File, trim(hist_coords(mdimind)%dimname), & + hist_coords(mdimind)%dimsize, dimid, & + existOK=(trim(hist_coords(mdimind)%dimname) /= & + trim(hist_coords(mdimind)%name))) + else + ! The dimension has the same name as the coord -- must be new dim + call cam_pio_def_dim(File, trim(hist_coords(mdimind)%name), & + hist_coords(mdimind)%dimsize, dimid, existOK=.false.) + end if + ! If the caller wants to know the NetCDF dimension ID, set it here + if (present(mdimid)) then + mdimid = dimid + end if + if (.not. dimonly) then + ! Time to define the variable (only if there are values) + if (hist_coords(mdimind)%integer_dim) then + dtype = pio_int + defvar = associated(hist_coords(mdimind)%integer_values) + else + dtype = pio_double + defvar = associated(hist_coords(mdimind)%real_values) + end if + if (defvar) then + call cam_pio_def_var(File, trim(hist_coords(mdimind)%name), dtype, & + (/dimid/), vardesc, existOK=.false.) + ! long_name + ierr=pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_hist_coord_attr') + ! units + if(len_trim(hist_coords(mdimind)%units) > 0) then + ierr=pio_put_att(File, vardesc, 'units', & + trim(hist_coords(mdimind)%units)) + call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_hist_coord_attr') + end if + ! positive + if(len_trim(hist_coords(mdimind)%positive) > 0) then + ierr=pio_put_att(File, vardesc, 'positive', & + trim(hist_coords(mdimind)%positive)) + call cam_pio_handle_error(ierr, 'Error writing "positive" attr in write_hist_coord_attr') + end if + ! standard_name + if(len_trim(hist_coords(mdimind)%standard_name) > 0) then + ierr=pio_put_att(File, vardesc, 'standard_name', & + trim(hist_coords(mdimind)%standard_name)) + call cam_pio_handle_error(ierr, 'Error writing "standard_name" attr in write_hist_coord_attr') + end if + ! formula_terms + if(len_trim(hist_coords(mdimind)%formula_terms%a_name) > 0) then + write(formula_terms, '("a: ",a," b: ",a," p0: ",a," ps: ",a)') & + trim(hist_coords(mdimind)%formula_terms%a_name), & + trim(hist_coords(mdimind)%formula_terms%b_name), & + trim(hist_coords(mdimind)%formula_terms%p0_name), & + trim(hist_coords(mdimind)%formula_terms%ps_name) + ierr=pio_put_att(File, vardesc, 'formula_terms', trim(formula_terms)) + call cam_pio_handle_error(ierr, 'Error writing "formula_terms" attr in write_hist_coord_attr') + end if + ! bounds + if (associated(hist_coords(mdimind)%bounds)) then + ! Write name of the bounds variable + ierr=pio_put_att(File, vardesc, 'bounds', trim(hist_coords(mdimind)%bounds_name)) + call cam_pio_handle_error(ierr, 'Error writing "bounds" attr in write_hist_coord_attr') + end if + end if + + ! Now, we need to define and populate the associated bounds variable + ! NB: Reusing vardesc, no longer assocated with main variable + if (associated(hist_coords(mdimind)%bounds)) then + if (size(hist_coords(mdimind)%bounds,2) /= hist_coords(mdimind)%dimsize) then + ! If anyone hits this check, add a new dimension for this case + write(errormsg, *) 'The bounds variable, ', & + trim(hist_coords(mdimind)%bounds_name), & + ', needs to have dimension (2,', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%bounds_name), & + pio_double, (/boundsdim,dimid/), vardesc, existOK=.false.) + end if + + ! See if we have formula_terms variables to define + ! Define the "a" variable name + ! NB: Reusing vardesc, no longer assocated with previous variables + if (associated(hist_coords(mdimind)%formula_terms%a_values)) then + if (size(hist_coords(mdimind)%formula_terms%a_values) /= hist_coords(mdimind)%dimsize) then + write(errormsg, *) 'The forumla_terms variable, ', & + trim(hist_coords(mdimind)%formula_terms%a_name), & + ', needs to have dimension', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%a_name), & + pio_double, (/dimid/), vardesc, existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%a_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "a" formula_term in write_hist_coord_attr') + end if + ! Define the "b" variable name + ! NB: Reusing vardesc, no longer assocated with previous variables + if (associated(hist_coords(mdimind)%formula_terms%b_values)) then + if (size(hist_coords(mdimind)%formula_terms%b_values) /= hist_coords(mdimind)%dimsize) then + write(errormsg, *) 'The forumla_terms variable, ', & + trim(hist_coords(mdimind)%formula_terms%b_name), & + ', needs to have dimension', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%b_name), & + pio_double, (/dimid/), vardesc, existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%b_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "b" formula_term in write_hist_coord_attr') + end if + ! Maybe define the p0 variable (this may be defined already which is OK) + ! NB: Reusing vardesc, no longer assocated with previous variables + if (hist_coords(mdimind)%formula_terms%p0_value /= fillvalue) then + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%p0_name), vardesc) + if (ierr /= PIO_NOERR) then + ierr = pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%p0_name), & + pio_double, vardesc) + call cam_pio_handle_error(ierr, 'Unable to define "p0" formula_terms variable in write_hist_coord_attr') + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%p0_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "p0" formula_term in write_hist_coord_attr') + ierr = pio_put_att(File, vardesc, 'units', trim(hist_coords(mdimind)%formula_terms%p0_units)) + call cam_pio_handle_error(ierr, 'Error writing "units" attr for "p0" formula_term in write_hist_coord_attr') + end if + end if + ! PS is not our responsibility + end if ! (.not. dimonly) + + end subroutine write_hist_coord_attr + + !--------------------------------------------------------------------------- + ! + ! write_hist_coord_attrs + ! + ! Write the dimension and coordinate attributes for the defined history + ! coordinates. + ! + !--------------------------------------------------------------------------- + subroutine write_hist_coord_attrs(File, boundsdim, mdimids, writemdims_in) + use pio, only: file_desc_t, var_desc_t, pio_put_att, & + pio_bcast_error, pio_internal_error, pio_seterrorhandling, & + pio_char + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: boundsdim ! Bounds dimension ID + integer, optional, allocatable, intent(out) :: mdimids(:) ! NetCDF dim IDs + logical, optional, intent(in) :: writemdims_in ! Write mdim variable + + ! Local variables + integer :: i + integer :: ierr + integer :: err_handling + integer :: dimids(2) ! PIO dimension IDs + logical :: writemdims ! Define an mdim variable + type(var_desc_t) :: vardesc ! PIO variable descriptor + + if (present(mdimids)) then + allocate(mdimids(registeredmdims)) + end if + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) + + if (present(writemdims_in)) then + writemdims = writemdims_in + else + writemdims = .false. + end if + + ! NB: Currently, writemdims is for restart and we don't need to write + ! these out in a history-restart file. This could change in the future. + ! which would require a change to the function of the fourth argument + ! Fill in the attribute information for each mdim + do i = 1, registeredmdims + if (present(mdimids)) then + call write_hist_coord_attr(File, i, boundsdim, writemdims, mdimids(i)) + else + call write_hist_coord_attr(File, i, boundsdim, writemdims) + end if + end do + + if (writemdims) then + call cam_pio_def_dim(File, 'mdimslen', max_hcoordname_len, dimids(1), & + existOK=.true.) + call cam_pio_def_dim(File, 'num_mdims', registeredmdims, dimids(2), & + existOK=.true.) + call cam_pio_def_var(File, mdim_var_name, pio_char, dimids, vardesc, & + existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', 'mdim dimension names') + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for mdimnames in write_hist_coord_attrs') + + end if + + ! Back to I/O or die trying + call pio_seterrorhandling(File, err_handling) + end subroutine write_hist_coord_attrs + + subroutine write_hist_coord_var(File, mdimind) + use pio, only: file_desc_t, var_desc_t, pio_put_var, pio_inq_varid + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: mdimind ! Internal dim index + + ! Local variables + type(var_desc_t) :: vardesc ! PIO variable descriptor + integer :: ierr + + if ((hist_coords(mdimind)%integer_dim .and. & + associated(hist_coords(mdimind)%integer_values)) .or. & + ((.not. hist_coords(mdimind)%integer_dim) .and. & + associated(hist_coords(mdimind)%real_values))) then + ! Check to make sure the variable already exists in the file + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent dimension variable write_hist_coord_var') + ! Write out the values for this dimension variable + if (hist_coords(mdimind)%integer_dim) then + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%integer_values) + else + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%real_values) + end if + call cam_pio_handle_error(ierr, 'Error writing variable values in write_hist_coord_var') + end if + + ! Now, we need to possibly write values for the associated bounds variable + if (associated(hist_coords(mdimind)%bounds)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%bounds_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent bounds variable write_hist_coord_var') + ! Write out the values for this bounds variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%bounds) + call cam_pio_handle_error(ierr, 'Error writing bounds values in write_hist_coord_var') + end if + + ! Write values for the "a" variable name + if (associated(hist_coords(mdimind)%formula_terms%a_values)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%a_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "a" formula_terms variable write_hist_coord_var') + ! Write out the values for this "a" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%a_values) + call cam_pio_handle_error(ierr, 'Error writing "a" formula_terms values in write_hist_coord_var') + end if + ! Write values for the "b" variable name + if (associated(hist_coords(mdimind)%formula_terms%b_values)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%b_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "b" formula_terms variable write_hist_coord_var') + ! Write out the values for this "b" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%b_values) + call cam_pio_handle_error(ierr, 'Error writing "b" formula_terms values in write_hist_coord_var') + end if + ! Write values for the "p0" variable name (this may be an overwrite, too bad) + if (hist_coords(mdimind)%formula_terms%p0_value /= fillvalue) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%p0_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "p0" formula_terms variable write_hist_coord_var') + ! Write out the values for this "p0" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%p0_value) + call cam_pio_handle_error(ierr, 'Error writing "p0" formula_terms values in write_hist_coord_var') + end if + + end subroutine write_hist_coord_var + + subroutine write_hist_coord_vars(File, writemdims_in) + use pio, only: file_desc_t, var_desc_t, pio_put_var, & + pio_bcast_error, pio_internal_error, & + pio_seterrorhandling, pio_inq_varid + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + logical, optional, intent(in) :: writemdims_in ! Write mdim variable + + ! Local variables + integer :: i + integer :: ierr + integer :: err_handling + logical :: writemdims ! Define an mdim variable + type(var_desc_t) :: vardesc ! PIO variable descriptor + character(len=max_hcoordname_len), allocatable :: mdimnames(:) + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) + + if (present(writemdims_in)) then + writemdims = writemdims_in + else + writemdims = .false. + end if + + if (writemdims) then + allocate(mdimnames(registeredmdims)) + end if + + ! Write out the variable values for each mdim + do i = 1, registeredmdims + if (.not. writemdims) then + ! NB: Currently, writemdims is for restart and we don't need to write + ! these out in a history-restart file. This could change in the future + ! which is why it is a separate if block + ! Fill in the attribute information for each mdim + call write_hist_coord_var(File, i) + end if + if (writemdims) then + mdimnames(i) = trim(hist_coords(i)%name) + end if + end do + + if (writemdims) then + ierr = pio_inq_varid(File, mdim_var_name, vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent mdimnames variable in write_hist_coord_vars') + ! Write out the values for mdim names + ierr = pio_put_var(File, vardesc, mdimnames) + call cam_pio_handle_error(ierr, 'Error writing values for mdimnames variable in write_hist_coord_vars') + deallocate(mdimnames) + end if + + ! Back to I/O or die trying + call pio_seterrorhandling(File, err_handling) + + end subroutine write_hist_coord_vars + + subroutine lookup_hist_coord_indices(mdimnames, mdimindicies) + ! Dummy arguments + character(len=*), intent(in) :: mdimnames(:) + integer, intent(out) :: mdimindicies(:) + + ! Local variables + integer :: i, j + integer :: cnt + character(len=120) :: errormsg + character(len=16) :: name + + + cnt = size(mdimnames) + mdimindicies = -1 + + + do j=1,cnt + name = mdimnames(j) + do i = 1, registeredmdims + if(name .eq. hist_coords(i)%name) then + mdimindicies(j)=i + end if + end do + end do + do j = 1, cnt + if(mdimindicies(j) < 0) then + do i = 1, registeredmdims + print *,__FILE__,__LINE__,i,hist_coords(i)%name + end do + write(errormsg,*) 'Name ',mdimnames(j),' is not a registered history coordinate' + call endrun(errormsg) + end if + end do + + end subroutine lookup_hist_coord_indices + + ! Find the vertical dimension (if present) in dimnames and return its size + ! (which is the number of levels). Return -1 if not found + ! If dimnames is not present, search all of the registered history coords + integer function hist_coord_find_levels(dimnames) result(levels) + ! Dummy argument + character(len=*), optional, intent(in) :: dimnames(:) + + ! Local variables + integer i, index, dimcnt + + levels = -1 ! Error return value + + if (present(dimnames)) then + dimcnt = size(dimnames) + else + dimcnt = registeredmdims + end if + + do i = 1, dimcnt + if (present(dimnames)) then + index = get_hist_coord_index(trim(dimnames(i))) + if (i < 0) then + call endrun('hist_coord_find_levels: '//trim(dimnames(i))//' is not a registred history coordinate') + end if + else + index = i ! Just cycle through all the registered mdims + end if + + if (hist_coords(index)%vertical_coord) then + levels = hist_coords(index)%dimsize + exit + end if + end do + + end function hist_coord_find_levels + + !####################################################################### + + character(len=8) function 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(iulog,*)'SEC2HRS: bad input seconds:', seconds + call endrun () + end if + + hours = seconds / 3600 + minutes = (seconds - hours*3600) / 60 + secs = (seconds - hours*3600 - minutes*60) + + if (minutes < 0 .or. minutes > 60) then + write(iulog,*)'SEC2HRS: bad minutes = ',minutes + call endrun () + end if + + if (secs < 0 .or. secs > 60) then + write(iulog,*)'SEC2HRS: bad secs = ',secs + call endrun () + end if + + write(sec2hms,80) hours, minutes, secs +80 format(i2.2,':',i2.2,':',i2.2) + return + end function sec2hms + character(len=10) function 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 endrun ('DATE2YYYYMMDD: negative date not allowed') + end if + + year = date / 10000 + month = (date - year*10000) / 100 + day = date - year*10000 - month*100 + + write(date2yyyymmdd,80) year, month, day +80 format(i4.4,'-',i2.2,'-',i2.2) + return + end function date2yyyymmdd + + !####################################################################### + +end module cam_history_support diff --git a/src/utils/cam_filenames.F90 b/src/utils/cam_filenames.F90 new file mode 100644 index 00000000..d445ce1c --- /dev/null +++ b/src/utils/cam_filenames.F90 @@ -0,0 +1,217 @@ +module cam_filenames + + ! Module and methods to handle filenames needed for the model. This + ! includes input filenames, and most output filenames that the model + ! uses. All filenames that the model uses will use methods or data + ! constructed by this module. In some cases (such as the cam_history module) + ! other modules or routines will store the actual filenames used, but + ! this module is used to determine the names. + + use shr_kind_mod, only: cl=>shr_kind_cl + use time_manager, only: get_curr_date, get_prev_date + use string_utils, only: to_str + use spmd_utils, only: masterproc + use cam_control_mod, only: caseid + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + + implicit none + private + save + + public :: get_dir ! Get the directory name from a full path + public :: interpret_filename_spec ! Interpret a filename specifier + +!============================================================================== +CONTAINS +!============================================================================== + + character(len=cl) function get_dir(filepath) + + ! Return the directory from a filename with a full path + + ! Dummy argument + character(len=*), intent(in) :: filepath ! Full path for a filename + + ! local variable + integer :: filenameposition ! Character pos for last character of directory + !------------------------------------------------------------------------ + + ! Get the directory name of the input dataset + filenameposition = index(filepath, '/', back=.true.) + if (filenameposition == 0)then + get_dir = './' + else + get_dir = filepath(1:filenameposition) + end if + + end function get_dir + + !=========================================================================== + + character(len=cl) function interpret_filename_spec(filename_spec, unit, & + prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec) + + ! Create a filename from a filename specifier. The + ! filename specifyer includes codes for setting things such as the + ! year, month, day, seconds in day, caseid, and file unit (e.g., h0, i). + ! + ! Interpret filename specifier string () with: + ! + ! %c for case () + ! %i for instance specification () + ! %u for unit specification () + ! %y for year () + ! %m for month () + ! %d for day () + ! %s for second () + ! %% for the "%" character + ! + ! If is present and .true. label the file with previous time-step + + ! Dummy Arguments + character(len=*), intent(in) :: filename_spec + character(len=*), optional, intent(in) :: unit + logical, optional, intent(in) :: prev + character(len=*), optional, intent(in) :: case + character(len=*), optional, intent(in) :: instance + integer, optional, intent(in) :: yr_spec + integer, optional, intent(in) :: mon_spec + integer, optional, intent(in) :: day_spec + integer, optional, intent(in) :: sec_spec + + ! Local variables + integer :: year ! Simulation year + integer :: month ! Simulation month + integer :: day ! Simulation day + integer :: ncsec ! Seconds into current simulation day + character(len=cl) :: string ! Temporary character string + character(len=cl) :: fmt_str ! Format character string + integer :: indx ! Loop variable + integer :: next ! Index location in + logical :: previous ! If should label with previous time-step + logical :: done + character(len=*), parameter :: subname = "INTERPRET_FILENAME_SPEC: " + !------------------------------------------------------------------------ + + if (len_trim(filename_spec) == 0)then + call endrun (subname//'filename specifier is empty') + end if + if (index(trim(filename_spec), " ") /= 0)then + call endrun(subname//"filename specifier can not contain a space:"// & + trim(filename_spec), file=__FILE__, line=__LINE__) + end if + ! + ! Determine year, month, day and sec to put in filename + ! + if (present(yr_spec) .and. present(mon_spec) .and. & + present(day_spec) .and. present(sec_spec)) then + year = yr_spec + month = mon_spec + day = day_spec + ncsec = sec_spec + else + if (present(prev)) then + previous = prev + else + previous = .false. + end if + if (previous) then + call get_prev_date(year, month, day, ncsec) + else + call get_curr_date(year, month, day, ncsec) + end if + end if + ! + ! Go through each character in the filename specifyer and interpret + ! if it is a format specifier + ! + indx = 1 + interpret_filename_spec = '' + do while (indx <= len_trim(filename_spec)) + ! + ! If following is an expansion string + ! + if (filename_spec(indx:indx) == "%") then + indx = indx + 1 + select case(filename_spec(indx:indx)) + case('c') ! caseid + if (present(case)) then + string = trim(case) + else + string = trim(caseid) + end if + case('u') ! unit description (e.g., h2) + if (.not. present(unit)) then + write(string, *) "unit needed in filename_spec, ", & + "but not provided to subroutine, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) + end if + string = trim(unit) + case('i') ! instance description (e.g., _0001) + if (.not. present(instance)) then + write(string, *) "instance needed in filename_spec, ", & + "but not provided to subroutine, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) + end if + string = trim(instance) + case('y') ! year + if (year > 99999) then + fmt_str = '(i6.6)' + else if (year > 9999) then + fmt_str = '(i5.5)' + else + fmt_str = '(i4.4)' + end if + write(string,fmt_str) year + case('m') ! month + write(string,'(i2.2)') month + case('d') ! day + write(string,'(i2.2)') day + case('s') ! second + write(string,'(i5.5)') ncsec + case('%') ! percent character + string = "%" + case default + call endrun(subname//"Invalid expansion character: "// & + filename_spec(indx:indx)) + end select + ! + ! Otherwise take normal text up to the next "%" character + ! + else + next = index(filename_spec(indx:), "%") + if (next == 0) then + next = len_trim(filename_spec(indx:)) + 1 + end if + if (next == 0) then + exit + end if + string = filename_spec(indx:next+indx-2) + indx = next + indx - 2 + end if + if (len_trim(interpret_filename_spec) == 0) then + interpret_filename_spec = trim(string) + else + if ((len_trim(interpret_filename_spec)+len_trim(string)) >= cl) then + call endrun(subname//"Resultant filename too long") + end if + interpret_filename_spec = trim(interpret_filename_spec)//trim(string) + end if + indx = indx + 1 + end do + if (len_trim(interpret_filename_spec) == 0) then + call endrun(subname//"Resulting filename is empty") + end if + + end function interpret_filename_spec + +end module cam_filenames diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90 index 5421d9e2..43c55c20 100644 --- a/src/utils/cam_pio_utils.F90 +++ b/src/utils/cam_pio_utils.F90 @@ -101,6 +101,7 @@ module cam_pio_utils end interface cam_permute_array interface cam_pio_dump_field + module procedure dump_field_1d_d module procedure dump_field_2d_d module procedure dump_field_3d_d module procedure dump_field_4d_d @@ -1324,7 +1325,7 @@ logical function cam_pio_fileexists(fname) end if ! Back to whatever error handling was running before this routine - call pio_seterrorhandling(File, err_handling) + call pio_seterrorhandling(pio_subsystem, err_handling) end function cam_pio_fileexists @@ -1447,6 +1448,112 @@ subroutine find_dump_filename(fieldname, filename) end subroutine find_dump_filename !=========================================================================== + subroutine dump_field_1d_d(fieldname, dim1b, dim1e, field, & + compute_maxdim_in, fill_value) + use pio, only: file_desc_t, var_desc_t, io_desc_t + use pio, only: pio_offset_kind, pio_enddef + use pio, only: pio_double, pio_int, pio_write_darray + use pio, only: pio_put_att, pio_initdecomp, pio_freedecomp + + use mpi, only: mpi_max, mpi_integer + use spmd_utils, only: iam, npes, mpicom + + ! Dummy arguments + character(len=*), intent(in) :: fieldname + integer, intent(in) :: dim1b + integer, intent(in) :: dim1e + real(r8), target, intent(in) :: field(dim1b:dim1e) + logical, optional, intent(in) :: compute_maxdim_in + real(r8), optional, intent(in) :: fill_value + + ! Local variables + type(file_desc_t) :: file + type(var_desc_t) :: vdesc + type(var_desc_t) :: bnddesc + type(io_desc_t) :: iodesc + character(len=64) :: filename + real(r8) :: fillval + integer(PIO_OFFSET_KIND), allocatable :: ldof(:) + integer :: dimids(2) + integer :: bnddimid + integer :: bounds(2) + integer :: dimsizes(2) + integer :: ierr + integer :: i, m, lsize + logical :: compute_maxdim + + ! Find an unused filename for this variable + call find_dump_filename(fieldname, filename) + + ! Should we compute max dim sizes or assume they are all the same? + if (present(compute_maxdim_in)) then + compute_maxdim = compute_maxdim_in + else + compute_maxdim = .true. + end if + + if (present(fill_value)) then + fillval = fill_value + else + fillval = -900._r8 + end if + + ! Open the file for writing + call cam_pio_createfile(file, trim(filename)) + + ! Define dimensions + if (compute_maxdim) then + call MPI_allreduce((dim1e - dim1b + 1), dimsizes(1), 1, MPI_integer, & + mpi_max, mpicom, ierr) + else + dimsizes(1) = dim1e - dim1b + 1 + end if + dimsizes(2) = npes + do i = 1, size(dimids, 1) + write(filename, '(a,i0)') 'dim', i + call cam_pio_def_dim(file, trim(filename), dimsizes(i), dimids(i)) + end do + call cam_pio_def_dim(file, 'bounds', size(bounds, 1), bnddimid) + ! Define the variables + call cam_pio_def_var(file, trim(fieldname), pio_double, dimids, vdesc) + call cam_pio_def_var(file, 'field_bounds', pio_int, & + (/ bnddimid, dimids(size(dimids, 1)) /), bnddesc) + if (present(fill_value)) then + ierr = pio_put_att(file, vdesc, '_FillValue', fill_value) + end if + ierr = pio_enddef(file) + + ! Compute the variable decomposition and write field + lsize = product(dimsizes(1:2)) + allocate(ldof(dim1e - dim1b + 1)) + m = 0 + do i = dim1b, dim1e + m = m + 1 + ldof(m) = (iam * lsize) + (i - dim1b + 1) + end do + call pio_initdecomp(pio_subsystem, PIO_DOUBLE, dimsizes, ldof, iodesc) + call pio_write_darray(file, vdesc, iodesc, field(dim1b:dim1e), & + ierr, fillval) + call pio_freedecomp(file, iodesc) + deallocate(ldof) + ! Compute the bounds decomposition and write field bounds + bounds(1) = dim1b + bounds(2) = dim1e + dimsizes(1) = size(bounds, 1) + dimsizes(2) = npes + allocate(ldof(size(bounds, 1))) + do i = 1, size(bounds, 1) + ldof(i) = (iam * size(bounds, 1)) + i + end do + call pio_initdecomp(pio_subsystem, PIO_INT, dimsizes(1:2), ldof, iodesc) + call pio_write_darray(file, bnddesc, iodesc, bounds, ierr, -900) + call pio_freedecomp(file, iodesc) + deallocate(ldof) + + ! All done + call cam_pio_closefile(file) + end subroutine dump_field_1d_d + subroutine dump_field_2d_d(fieldname, dim1b, dim1e, dim2b, dim2e, field, & compute_maxdim_in, fill_value) use pio, only: file_desc_t, var_desc_t, io_desc_t diff --git a/src/utils/cam_time_coord.F90 b/src/utils/cam_time_coord.F90 index 49b93277..32f02e52 100644 --- a/src/utils/cam_time_coord.F90 +++ b/src/utils/cam_time_coord.F90 @@ -43,11 +43,11 @@ module cam_time_coord !--------------------------------------------------------------------------- subroutine initialize(this, filepath, fixed, fixed_ymd, fixed_tod, & force_time_interp, set_weights, try_dates, delta_days) + use shr_string_mod, only: to_upper => shr_string_toUpper use cam_abortutils, only: check_allocate use ioFileMod, only: cam_get_file use cam_pio_utils, only: cam_pio_openfile, cam_pio_closefile use cam_pio_utils, only: cam_pio_handle_error - use string_utils, only: to_upper class(time_coordinate), intent(inout) :: this character(len=*), intent(in) :: filepath diff --git a/src/utils/string_utils.F90 b/src/utils/string_utils.F90 index 30f730e8..258793b7 100644 --- a/src/utils/string_utils.F90 +++ b/src/utils/string_utils.F90 @@ -8,16 +8,10 @@ module string_utils ! Public interface methods - public :: to_upper ! Convert character string to upper case - public :: to_lower ! Convert character string to lower case - public :: strlist_get_ind ! find string in a list of strings and return its index public :: increment_string ! increments a string public :: last_sig_char ! Position of last significant character in string public :: to_str ! convert integer to left justified string - - ! Private module variables - integer, parameter :: lower_to_upper = iachar("A") - iachar("a") - integer, parameter :: upper_to_lower = iachar("a") - iachar("A") + public :: parse_multiplier ! Parse a repeat count and a token from input CONTAINS @@ -83,7 +77,7 @@ integer function increment_string(str, increment) !----------------------------------------------------------------------- ! ... Dummy variables !----------------------------------------------------------------------- - character(len=*), intent(inout) :: str ! string with trailing digits + character(len=*), intent(inout) :: str ! string with trailing digits ! increment: value to increment string (may be negative) integer, intent(in) :: increment @@ -140,7 +134,7 @@ integer function increment_string(str, increment) end function increment_string -!========================================================================================= + !=========================================================================== integer function last_index(cstr) !----------------------------------------------------------------------- @@ -179,7 +173,7 @@ integer function last_index(cstr) end function last_index -!========================================================================================= + !=========================================================================== integer function last_sig_char(cstr) !----------------------------------------------------------------------- @@ -216,20 +210,117 @@ integer function last_sig_char(cstr) end function last_sig_char -!========================================================================================= + !=========================================================================== -character(len=10) function to_str(n) + character(len=10) function to_str(n) - ! return default integer as a left justified string + ! return default integer as a left justified string - ! arguments - integer, intent(in) :: n - !---------------------------------------------------------------------------- + ! arguments + integer, intent(in) :: n + !---------------------------------------------------------------------------- + + write(to_str,'(i0)') n + + end function to_str - write(to_str,'(i0)') n + !=========================================================================== + + subroutine parse_multiplier(input, multiplier, token, allowed_set, errmsg) + ! Parse a character string () to find a token , possibly + ! multiplied by an integer (). + ! Return values for : + ! positive integer: Successful return with and . + ! zero: is an empty string + ! -1: Error condition (malformed input string) + ! Return values for + ! On a successful return, will contain with the + ! optional multiplier and multiplication symbol removed. + ! On an error return, will be an empty string + ! + ! If is present, then must equal a value in + ! (case insensitive) + ! If is present, it is filled with an error message if + ! is not an allowed format. + ! Allowed formats are: + ! * where is the string representation + ! a positive integer. + ! in which case is assumed to be one. + ! + + ! Dummy arguments + character(len=*), intent(in) :: input + integer, intent(out) :: multiplier + character(len=*), intent(out) :: token + character(len=*), optional, intent(in) :: allowed_set(:) + character(len=*), optional, intent(out) :: errmsg + ! Local variables + integer :: mult_ind ! Index of multiplication symbol + integer :: lind ! Loop index + integer :: alen ! Number of entries in + integer :: stat ! Read status + logical :: match ! For matching + character(len=8) :: fmt_str ! Format string + + ! Initialize output + errmsg = '' + multiplier = -1 + token = '' + ! Do we have a multipler? + mult_ind = index(input, '*') + if (len_trim(input) == 0) then + multiplier = 0 + else if (mult_ind <= 0) then + multiplier = 1 + token = trim(input) + else + write(fmt_str, '(a,i0,a)') "(i", mult_ind - 1, ")" + read(input, fmt_str, iostat=stat) multiplier + if (stat == 0) then + token = trim(input(mult_ind+1:)) + else + if (present(errmsg)) then + write(errmsg, *) "Invalid multiplier, '", & + input(1:mult_ind-1), "' in '", trim(input), "'" + end if + multiplier = -1 + token = '' + end if + end if + + if ((multiplier >= 0) .and. present(allowed_set)) then + alen = size(allowed_set) + match = .false. + do lind = 1, alen + if (trim(to_lower(token)) == trim(to_lower(allowed_set(lind)))) then + match = .true. + exit + end if + end do + if (.not. match) then + if (present(errmsg)) then + write(errmsg, *) "Error, token, '", trim(token), "' not in (/" + lind = len_trim(errmsg) + 1 + do mult_ind = 1, alen + if (mult_ind == alen) then + fmt_str = "' " + else + fmt_str = "', " + end if + write(errmsg(lind:), *) "'", trim(allowed_set(mult_ind)), & + trim(fmt_str) + lind = lind + len_trim(allowed_set(mult_ind)) + & + len_trim(fmt_str) + 2 + end do + write(errmsg(lind:), *) "/)" + end if + multiplier = -1 + token = '' + end if + end if -end function to_str + end subroutine parse_multiplier -!========================================================================================= + !=========================================================================== end module string_utils diff --git a/src/utils/time_manager.F90 b/src/utils/time_manager.F90 index ed9159fb..1e132ed3 100644 --- a/src/utils/time_manager.F90 +++ b/src/utils/time_manager.F90 @@ -3,6 +3,7 @@ module time_manager ! Provide CAM specific time management. This is a wrapper layer for the ESMF ! time manager utility. + use shr_string_mod, only: to_upper => shr_string_toUpper use ESMF, only: ESMF_Calendar, ESMF_CalendarCreate use ESMF, only: ESMF_SUCCESS, ESMF_KIND_I8, ESMF_CalKind_Flag use ESMF, only: ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN @@ -16,7 +17,6 @@ module time_manager use shr_kind_mod, only: r8 => shr_kind_r8, SHR_KIND_CS use shr_cal_mod, only: shr_cal_noleap, shr_cal_gregorian use spmd_utils, only: masterproc - use string_utils, only: to_upper use cam_abortutils, only: endrun use cam_logfile, only: iulog diff --git a/test/hist_tests/CMakeLists.txt b/test/hist_tests/CMakeLists.txt new file mode 100644 index 00000000..b2074879 --- /dev/null +++ b/test/hist_tests/CMakeLists.txt @@ -0,0 +1,140 @@ +CMAKE_MINIMUM_REQUIRED(VERSION 3.11) +PROJECT(TestHistConfig) +ENABLE_LANGUAGE(Fortran) + +include(CMakeForceCompiler) + +find_package(MPI REQUIRED) +add_definitions(${MPI_Fortran_COMPILE_FLAGS}) +include_directories(${MPI_Fortran_INCLUDE_PATH}) +link_directories(${MPI_Fortran_LIBRARIES}) + +#----------------------------------------------------------------------------- +# +# Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) +# +#----------------------------------------------------------------------------- +GET_FILENAME_COMPONENT(TEST_PATH ${CMAKE_CURRENT_SOURCE_DIR} DIRECTORY) +SET(UTILS_PATH ${TEST_PATH}/include) +GET_FILENAME_COMPONENT(ROOT_PATH ${TEST_PATH} DIRECTORY) +SET(SRC_PATH ${ROOT_PATH}/src) +SET(HIST_PATH ${SRC_PATH}/history) +# Find CIME directory +if (EXISTS "${ROOT_PATH}/cime") + SET(CIME_PATH ${ROOT_PATH}/cime) +else(EXISTS "${ROOT_PATH}/cime") + GET_FILENAME_COMPONENT(_components ${ROOT_PATH} DIRECTORY) + GET_FILENAME_COMPONENT(_toplev ${_components} DIRECTORY) + SET(CIME_PATH ${_toplev}/cime) +endif(EXISTS "${ROOT_PATH}/cime") +# Test copies of CAM and CIME utility files +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_abortutils.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_logfile.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/ccpp_kinds.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/spmd_utils.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_infnan_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_assert_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_string_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/time_manager.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_control_mod.F90") +LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_interp_mod.F90") +LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_history_support.F90") +# Regular CAM and CIME utility files +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_kind_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_mpi_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_abort_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_sys_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_timer_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_log_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_nl_mod.F90") +LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_strconvert_mod.F90") +LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") +LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_filenames.F90") +# CAM history files +LIST(APPEND SOURCE_FILES "${HIST_PATH}/cam_hist_config_file.F90") +## We need to copy shr_assert.h into this directory +#configure_file("${CIME_PATH}/src/share/util/shr_assert.h" +# "${CMAKE_CURRENT_SOURCE_DIR}/shr_assert.h" COPYONLY) +# TEST_EXE.F90 is the name of the program source file +SET(TEST_EXE "test_history") +ADD_EXECUTABLE(${TEST_EXE} ${TEST_EXE}.F90) + +#----------------------------------------------------------------------------- +############################################################################## +# +# End of project-specific input +# +############################################################################## +#----------------------------------------------------------------------------- + +# Use rpaths on MacOSX +set(CMAKE_MACOSX_RPATH 1) + +#----------------------------------------------------------------------------- +# Set a default build type if none was specified +if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + #message(STATUS "Setting build type to 'Debug' as none was specified.") + #set(CMAKE_BUILD_TYPE Debug CACHE STRING "Choose the type of build." FORCE) + message(STATUS "Setting build type to 'Release' as none was specified.") + set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) + + # Set the possible values of build type for cmake-gui + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" + "MinSizeRel" "RelWithDebInfo") +endif() + +ADD_COMPILE_OPTIONS(-O0) + +if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") +# gfortran +# MESSAGE("gfortran being used.") + ADD_COMPILE_OPTIONS(-fcheck=all) + ADD_COMPILE_OPTIONS(-fbacktrace) + ADD_COMPILE_OPTIONS(-ffpe-trap=zero) + ADD_COMPILE_OPTIONS(-finit-real=nan) + ADD_COMPILE_OPTIONS(-ggdb) + ADD_COMPILE_OPTIONS(-ffree-line-length-none) + ADD_COMPILE_OPTIONS(-cpp) + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DHAVE_IEEE_ARITHMETIC") +elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") +# ifort +# MESSAGE("ifort being used.") + #ADD_COMPILE_OPTIONS(-check all) + ADD_COMPILE_OPTIONS(-fpe0) + ADD_COMPILE_OPTIONS(-warn) + ADD_COMPILE_OPTIONS(-traceback) + ADD_COMPILE_OPTIONS(-debug extended) + ADD_COMPILE_OPTIONS(-fpp) +elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") +# pgf90 +# MESSAGE("pgf90 being used.") + ADD_COMPILE_OPTIONS(-g) + ADD_COMPILE_OPTIONS(-Mipa=noconst) + ADD_COMPILE_OPTIONS(-traceback) + ADD_COMPILE_OPTIONS(-Mfree) + ADD_COMPILE_OPTIONS(-Mfptrap) + ADD_COMPILE_OPTIONS(-Mpreprocess) +else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") + message (FATAL_ERROR "This program has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${CMAKE_SOURCE_DIR}/CMakeLists.txt") +endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") +set (CMAKE_Fortran_FLAGS + "${CMAKE_Fortran_FLAGS} -I${ROOT_PATH}/share/include") + +#----------------------------------------------------------------------------- +# Set OpenMP flags for C/C++/Fortran +if (OPENMP) + include(detect_openmp) + detect_openmp() + set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ${OpenMP_C_FLAGS}") + set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${OpenMP_CXX_FLAGS}") + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") + message(STATUS "Enable OpenMP support for C/C++/Fortran compiler") +else(OPENMP) + message (STATUS "Disable OpenMP support for C/C++/Fortran compiler") +endif() +TARGET_SOURCES(${TEST_EXE} PUBLIC ${SOURCE_FILES}) +TARGET_LINK_LIBRARIES(${TEST_EXE} ${MPI_Fortran_LIBRARIES}) + +set_target_properties(${TEST_EXE} PROPERTIES + COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" + LINK_FLAGS "${CMAKE_Fortran_FLAGS}") diff --git a/test/hist_tests/cam_history_support.F90 b/test/hist_tests/cam_history_support.F90 new file mode 100644 index 00000000..3a527ee6 --- /dev/null +++ b/test/hist_tests/cam_history_support.F90 @@ -0,0 +1,9 @@ +module cam_history_support + + implicit none + private + save + + integer, public :: max_fieldname_len = 63 + +end module cam_history_support diff --git a/test/hist_tests/cam_interp_mod.F90 b/test/hist_tests/cam_interp_mod.F90 new file mode 100644 index 00000000..0b9e6a5c --- /dev/null +++ b/test/hist_tests/cam_interp_mod.F90 @@ -0,0 +1,60 @@ +module cam_interp_mod + + use shr_kind_mod, only: r8=>shr_kind_r8 + + implicit none + private + + ! Some parameters for use with interpolated output namelist items + integer, parameter, public :: interp_type_native = 0 + integer, parameter, public :: interp_type_bilinear = 1 + integer, parameter, public :: interp_gridtype_equal_poles = 1 + integer, parameter, public :: interp_gridtype_gauss = 2 + integer, parameter, public :: interp_gridtype_equal_nopoles = 3 + + type, public :: hist_interp_info_t + ! store the lat-lon grid information + character(len=28) :: gridname = '' + integer :: grid_id = -1 + ! gridtype = 1 equally spaced, including poles (FV scalars output grid) + ! gridtype = 2 Gauss grid (CAM Eulerian) + ! gridtype = 3 equally spaced, no poles (FV staggered velocity) + integer :: interp_gridtype = interp_gridtype_equal_poles + ! interpolate_type = 0: native high order interpolation + ! interpolate_type = 1: bilinear interpolation + integer :: interp_type = interp_type_bilinear + integer :: interp_nlat = 0 + integer :: interp_nlon = 0 + real(r8), pointer :: interp_lat(:) => NULL() + real(r8), pointer :: interp_lon(:) => NULL() + real(r8), pointer :: interp_gweight(:) => NULL() + contains + procedure :: reset => interp_reset + end type hist_interp_info_t + +CONTAINS + + subroutine interp_reset(this) + class(hist_interp_info_t), intent(inout) :: this + + this%gridname = '' + this%grid_id = -1 + this%interp_gridtype = interp_gridtype_equal_poles + this%interp_type = interp_type_bilinear + this%interp_nlat = 0 + this%interp_nlon = 0 + if (associated(this%interp_lat)) then + deallocate(this%interp_lat) + nullify(this%interp_lat) + end if + if (associated(this%interp_lon)) then + deallocate(this%interp_lon) + nullify(this%interp_lon) + end if + if (associated(this%interp_gweight)) then + deallocate(this%interp_gweight) + nullify(this%interp_gweight) + end if + end subroutine interp_reset + +end module cam_interp_mod diff --git a/test/hist_tests/sample_files/amwg_hist_config b/test/hist_tests/sample_files/amwg_hist_config new file mode 100644 index 00000000..799ab339 --- /dev/null +++ b/test/hist_tests/sample_files/amwg_hist_config @@ -0,0 +1,17 @@ +max_frames: 1 +output_frequency: monthly +precision: REAL32 +output_levels: IPCC_PRESSURE_LEVELS + +! ADF mean +diag_file: adf_mean_config +! Radiation +!diag_file: rad_config +! Gravity wave +diag_file: grav_wav_config +! Turbulent mountain stress +add_avg_fields: TAUTMSX, TAUTMSY +! Modal aerosol optics +add_avg_fields: AODDUST1, AODDUST3, AODDUST, AODVIS +! ndrop +add_avg_fields: CCN3 diff --git a/test/hist_tests/sample_files/rrtmg_rad_config b/test/hist_tests/sample_files/rrtmg_rad_config new file mode 100644 index 00000000..ff5971c2 --- /dev/null +++ b/test/hist_tests/sample_files/rrtmg_rad_config @@ -0,0 +1,46 @@ +add_avg_fields;h0: SOLIN, SOLIN_d1, SOLIN_d2, SOLIN_d3, SOLIN_d4, SOLIN_d5 +add_avg_fields;h4: SOLIN_d6, SOLIN_d7, SOLIN_d8, SOLIN_d9, SOLIN_d10 +add_avg_fields: QRS, QRS_d1, QRS_d2, QRS_d3, QRS_d4, QRS_d5 +add_avg_fields: QRS_d6, QRS_d7, QRS_d8, QRS_d9, QRS_d10 +add_avg_fields: FSNT, FSNT_d1, FSNT_d2, FSNT_d3, FSNT_d4, FSNT_d5 +add_avg_fields: FSNT_d6, FSNT_d7, FSNT_d8, FSNT_d9, FSNT_d10 +add_avg_fields: FSNTC, FSNTC_d1, FSNTC_d2, FSNTC_d3, FSNTC_d4, FSNTC_d5 +add_avg_fields: FSNTC_d6, FSNTC_d7, FSNTC_d8, FSNTC_d9, FSNTC_d10 +add_avg_fields: FSNTOA, FSNTOA_d1, FSNTOA_d2, FSNTOA_d3, FSNTOA_d4, FSNTOA_d5 +add_avg_fields: FSNTOA_d6, FSNTOA_d7, FSNTOA_d8, FSNTOA_d9, FSNTOA_d10 +add_avg_fields: FSNTOAC, FSNTOAC_d1, FSNTOAC_d2, FSNTOAC_d3, FSNTOAC_d4, FSNTOAC_d5 +add_avg_fields: FSNTOAC_d6, FSNTOAC_d7, FSNTOAC_d8, FSNTOAC_d9, FSNTOAC_d10 +add_avg_fields: SWCF, SWCF_d1, SWCF_d2, SWCF_d3, SWCF_d4, SWCF_d5 +add_avg_fields: SWCF_d6, SWCF_d7, SWCF_d8, SWCF_d9, SWCF_d10 +add_avg_fields: FSNS, FSNS_d1, FSNS_d2, FSNS_d3, FSNS_d4, FSNS_d5 +add_avg_fields: FSNS_d6, FSNS_d7, FSNS_d8, FSNS_d9, FSNS_d10 +add_avg_fields: FSNSC, FSNSC_d1, FSNSC_d2, FSNSC_d3, FSNSC_d4, FSNSC_d5 +add_avg_fields: FSNSC_d6, FSNSC_d7, FSNSC_d8, FSNSC_d9, FSNSC_d10 +add_avg_fields: FSUTOA, FSUTOA_d1, FSUTOA_d2, FSUTOA_d3, FSUTOA_d4, FSUTOA_d5 +add_avg_fields: FSUTOA_d6, FSUTOA_d7, FSUTOA_d8, FSUTOA_d9, FSUTOA_d10 +add_avg_fields: FSDSC, FSDSC_d1, FSDSC_d2, FSDSC_d3, FSDSC_d4, FSDSC_d5 +add_avg_fields: FSDSC_d6, FSDSC_d7, FSDSC_d8, FSDSC_d9, FSDSC_d10 +add_avg_fields: FSDS, FSDS_d1, FSDS_d2, FSDS_d3, FSDS_d4, FSDS_d5 +add_avg_fields: FSDS_d6, FSDS_d7, FSDS_d8, FSDS_d9, FSDS_d10 +add_avg_fields: QRL, QRL_d1, QRL_d2, QRL_d3, QRL_d4, QRL_d5 +add_avg_fields: QRL_d6, QRL_d7, QRL_d8, QRL_d9, QRL_d10 +add_avg_fields: FLNT, FLNT_d1, FLNT_d2, FLNT_d3, FLNT_d4, FLNT_d5 +add_avg_fields: FLNT_d6, FLNT_d7, FLNT_d8, FLNT_d9, FLNT_d10 +add_avg_fields: FLNTC, FLNTC_d1, FLNTC_d2, FLNTC_d3, FLNTC_d4, FLNTC_d5 +add_avg_fields: FLNTC_d6, FLNTC_d7, FLNTC_d8, FLNTC_d9, FLNTC_d10 +add_avg_fields: FLNTCLR, FLNTCLR_d1, FLNTCLR_d2, FLNTCLR_d3, FLNTCLR_d4, FLNTCLR_d5 +add_avg_fields: FLNTCLR_d6, FLNTCLR_d7, FLNTCLR_d8, FLNTCLR_d9, FLNTCLR_d10 +add_avg_fields: FREQCLR, FREQCLR_d1, FREQCLR_d2, FREQCLR_d3, FREQCLR_d4, FREQCLR_d5 +add_avg_fields: FREQCLR_d6, FREQCLR_d7, FREQCLR_d8, FREQCLR_d9, FREQCLR_d10 +add_avg_fields: FLUT, FLUT_d1, FLUT_d2, FLUT_d3, FLUT_d4, FLUT_d5 +add_avg_fields: FLUT_d6, FLUT_d7, FLUT_d8, FLUT_d9, FLUT_d10 +add_avg_fields: FLUTC, FLUTC_d1, FLUTC_d2, FLUTC_d3, FLUTC_d4, FLUTC_d5 +add_avg_fields: FLUTC_d6, FLUTC_d7, FLUTC_d8, FLUTC_d9, FLUTC_d10 +add_avg_fields: LWCF, LWCF_d1, LWCF_d2, LWCF_d3, LWCF_d4, LWCF_d5 +add_avg_fields: LWCF_d6, LWCF_d7, LWCF_d8, LWCF_d9, LWCF_d10 +add_avg_fields: FLNS, FLNS_d1, FLNS_d2, FLNS_d3, FLNS_d4, FLNS_d5 +add_avg_fields: FLNS_d6, FLNS_d7, FLNS_d8, FLNS_d9, FLNS_d10 +add_avg_fields: FLNSC, FLNSC_d1, FLNSC_d2, FLNSC_d3, FLNSC_d4, FLNSC_d5 +add_avg_fields: FLNSC_d6, FLNSC_d7, FLNSC_d8, FLNSC_d9, FLNSC_d10 +add_avg_fields: FLDS, FLDS_d1, FLDS_d2, FLDS_d3, FLDS_d4, FLDS_d5 +add_avg_fields: FLDS_d6, FLDS_d7, FLDS_d8, FLDS_d9, FLDS_d10 diff --git a/test/hist_tests/sample_files/single_good_config.nl b/test/hist_tests/sample_files/single_good_config.nl new file mode 100644 index 00000000..61bbf17d --- /dev/null +++ b/test/hist_tests/sample_files/single_good_config.nl @@ -0,0 +1,16 @@ +! History file configuration with a single good entry +&hist_config_arrays_nl + hist_num_inst_fields = 3 + hist_num_avg_fields = 0 + hist_num_min_fields = 0 + hist_num_max_fields = 0 + hist_num_var_fields = 0 +/ + +&hist_file_config_nl + hist_volume = 'h1' + hist_inst_fields = 'A','B','C' + hist_precision = 'REAL32' + hist_max_frames = 13 + hist_output_frequency = '2*hours' +/ diff --git a/test/hist_tests/sample_files/two_good_configs.nl b/test/hist_tests/sample_files/two_good_configs.nl new file mode 100644 index 00000000..31e28334 --- /dev/null +++ b/test/hist_tests/sample_files/two_good_configs.nl @@ -0,0 +1,26 @@ +! History file configuration with two good entries +&hist_config_arrays_nl + hist_num_inst_fields = 3 + hist_num_avg_fields = 5 + hist_num_min_fields = 0 + hist_num_max_fields = 0 + hist_num_var_fields = 0 +/ + +&hist_file_config_nl + hist_volume = 'h1' + hist_inst_fields = 'A','B','C' + hist_precision = 'REAL32' + hist_max_frames = 13 + hist_output_frequency = '2*hours' + hist_file_type = 'history' +/ + +&hist_file_config_nl + hist_volume = 'h0' + hist_avg_fields = 'd','E', 'f', 'g' , "H" + hist_precision = 'REAL64' + hist_max_frames = 30 + hist_output_frequency = 'monthly' + hist_file_type = 'history' +/ diff --git a/test/hist_tests/sample_files/user_nl_cam b/test/hist_tests/sample_files/user_nl_cam new file mode 100644 index 00000000..d0026816 --- /dev/null +++ b/test/hist_tests/sample_files/user_nl_cam @@ -0,0 +1,17 @@ +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value + +ncdata = '/home/cesmdata/camden/kess_data.cam.h6.ne5.nc' +use_topo_file = .false. + +history_no_defaults: True +! History configuration +diag_file;h0: amwg_hist_config +remove_avg_fields;h0 TAUTMSX, TAUTMSY +output_levels;h0: IPCC_PRESSURE_LEVELS +add_pressure_levels;h0: 925hPa, 850, 500, 320 + + +output_levels;h3: MODEL_LEVELS +add_inst_fields;h3: T, U, V +output_frequency;h3: 2*nsteps diff --git a/test/hist_tests/sample_files/user_nl_cam_rrtmg b/test/hist_tests/sample_files/user_nl_cam_rrtmg new file mode 100644 index 00000000..8adf7dde --- /dev/null +++ b/test/hist_tests/sample_files/user_nl_cam_rrtmg @@ -0,0 +1,15 @@ +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value + +ncdata = '/home/cesmdata/camden/kess_data.cam.h6.ne5.nc' +use_topo_file = .false. + +! History configuration +diag_file;h0: rrtmg_rad_config +output_frequency;h0: monthly +precision;h0: REAL32 + +add_inst_fields;h3: T, U, V +output_frequency;h3: 2*nsteps +precision;h3: REAL64 +max_frames;h3: 24 diff --git a/test/hist_tests/test_history.F90 b/test/hist_tests/test_history.F90 new file mode 100644 index 00000000..a7f50e73 --- /dev/null +++ b/test/hist_tests/test_history.F90 @@ -0,0 +1,175 @@ +module test_hist_mod + + implicit none + private + + public :: run_test + +CONTAINS + + subroutine run_test(test_msg, test_file, sample_dir, out_unit, & + num_configs, volumes, max_frames, precisions, & + test_cnt, err_cnt) + use shr_kind_mod, only: max_flen=>SHR_KIND_CL + use cam_abortutils, only: endrun, check_endrun + use cam_hist_config_file, only: hist_file_config_t + use cam_hist_config_file, only: hist_read_namelist_config + + ! Dummy arguments + character(len=*), intent(in) :: test_msg + character(len=*), intent(in) :: test_file + character(len=*), intent(in) :: sample_dir + integer, intent(in) :: num_configs + character(len=*), intent(in) :: volumes(:) + integer, intent(in) :: max_frames(:) + character(len=*), intent(in) :: precisions(:) + integer, intent(in) :: out_unit + integer, intent(out) :: test_cnt + integer, intent(out) :: err_cnt + ! Local variables + type(hist_file_config_t), pointer :: tconfig_arr(:) + character(len=max_flen) :: test_path + integer :: indx + + test_cnt = 0 + err_cnt = 0 + test_cnt = test_cnt + 1 ! Did read work? + test_path = trim(sample_dir)//trim(test_file) + tconfig_arr => hist_read_namelist_config(test_path) + if (check_endrun(test_desc=test_msg, output=out_unit)) then + err_cnt = err_cnt + 1 + end if + if (err_cnt == 0) then + test_cnt = test_cnt + 1 ! Did the config array get allocated? + if (.not. associated(tconfig_arr)) then + err_cnt = err_cnt + 1 + write(out_unit, *) "FAIL: ", trim(test_msg), & + ": tconfig_arr not allocated" + end if + end if + if (err_cnt == 0) then + test_cnt = test_cnt + 1 ! Is the config array the right size? + if (size(tconfig_arr) /= num_configs) then + err_cnt = err_cnt + 1 + write(out_unit, '(3a,i0,a,i0)') "FAIL: ", trim(test_msg), & + ": tconfig_arr has ", size(tconfig_arr), & + " entries, should be ", num_configs + end if + do indx = 1, num_configs + test_cnt = test_cnt + 1 ! Is volume correct? + if (trim(tconfig_arr(indx)%filename()) /= trim(volumes(indx))) then + err_cnt = err_cnt + 1 + write(out_unit, '(3a,i0,4a)') "FAIL: ", trim(test_msg), & + ": volume(", indx, ") is ", & + trim(tconfig_arr(indx)%filename()), ", should be ", & + trim(volumes(indx)) + end if + test_cnt = test_cnt + 1 ! Is max_frames correct? + if (tconfig_arr(indx)%max_frame() /= max_frames(indx)) then + err_cnt = err_cnt + 1 + write(out_unit, '(3a,i0,a,i0)') "FAIL: ", trim(test_msg), & + ": tconfig_arr has max_frames = ", & + tconfig_arr(indx)%max_frame(), ", should be ", & + max_frames(indx) + end if + test_cnt = test_cnt + 1 ! Is precision correct? + if (tconfig_arr(indx)%precision() /= precisions(indx)) then + err_cnt = err_cnt + 1 + write(out_unit, '(3a,i0,4a)') "FAIL: ", trim(test_msg), & + ": precision(", indx, ") is ", & + trim(tconfig_arr(indx)%precision()), ", should be ", & + trim(precisions(indx)) + end if + end do + end if + + end subroutine run_test + +end module test_hist_mod + +!========================================================================= + +program test_history + + use shr_kind_mod, only: max_chars=>SHR_KIND_CX + use shr_kind_mod, only: max_flen=>SHR_KIND_CL + use cam_abortutils, only: endrun, check_endrun + use cam_hist_config_file, only: hist_file_config_t + use cam_hist_config_file, only: hist_read_namelist_config + use test_hist_mod, only: run_test + + implicit none + + integer :: out_unit = 6 + integer :: ierr + integer :: errcnt + integer :: testcnt + integer :: total_errcnt = 0 + integer :: total_tests = 0 + character(len=max_flen) :: sample_dir + character(len=max_flen) :: test_file + character(len=max_chars) :: test_msg + type(hist_file_config_t), pointer :: test_config_arr(:) + + ! Get sample directory from command line + errcnt = command_argument_count() + if (errcnt /= 1) then + call get_command_argument(0, value=test_file, status=ierr) + if (ierr > 0) then + test_file = "test_history.F90" + end if + write(6, *) "USAGE: ", trim(test_file), " " + STOP 1 + end if + call get_command_argument(1, value=sample_dir, status=ierr) + if (ierr > 0) then + write(6, *) "ERROR retrieving from command line" + STOP 1 + else if ((ierr < 0) .or. (len_trim(sample_dir) == max_flen)) then + write(6, *) "ERROR too long" + STOP 1 + end if + if (sample_dir(len_trim(sample_dir):len_trim(sample_dir)) /= "/") then + sample_dir = trim(sample_dir)//"/" + end if + + call MPI_init(errcnt) + + ! Read non-existent file test + test_file = trim(sample_dir)//"ThisFileBetterNotExist.fool" + test_config_arr => hist_read_namelist_config(test_file) + total_tests = total_tests + 1 + if (.not. check_endrun()) then + total_errcnt = total_errcnt + 1 + write(out_unit, *) "FAIL: Non-existent file read test" + end if + + ! Read single-good config test + test_file = "single_good_config.nl" + test_msg = "single_good_config.nl file read test" + call run_test(test_msg, test_file, sample_dir, out_unit, 1, (/ 'h1' /), & + (/ 13 /), (/ 'REAL32' /), testcnt, errcnt) + total_tests = total_tests + testcnt + total_errcnt = total_errcnt + errcnt + + ! Read single-good config test + test_file = "two_good_configs.nl" + test_msg = "two_good_configs.nl file read test" + call run_test(test_msg, test_file, sample_dir, out_unit, 2, & + (/ 'h1', 'h0' /), (/ 13, 30 /), (/ 'REAL32', 'REAL64' /), & + testcnt, errcnt) + total_tests = total_tests + testcnt + total_errcnt = total_errcnt + errcnt + + call MPI_finalize(errcnt) + + if (total_errcnt > 0) then + write(6, '(2(a,i0))') 'FAIL, error count = ', total_errcnt, & + ' / ', total_tests + STOP 1 + else + write(6, '(a,i0,a)') "All ", total_tests, " history tests passed!" + STOP 0 + end if + +end program test_history diff --git a/test/include/cam_abortutils.F90 b/test/include/cam_abortutils.F90 index 8db9729e..59bdfe37 100644 --- a/test/include/cam_abortutils.F90 +++ b/test/include/cam_abortutils.F90 @@ -1,17 +1,79 @@ module cam_abortutils - implicit none - private + use shr_kind_mod, only: max_chars=>SHR_KIND_CX - public endrun + implicit none + private + + public :: endrun + public :: check_endrun + public :: check_allocate + + character(len=max_chars) :: abort_msg = '' CONTAINS - subroutine endrun(msg) - character(len=*), intent(in) :: msg + logical function check_endrun(test_desc, output) + character(len=*), optional, intent(in) :: test_desc + integer, optional, intent(in) :: output + + ! Return .true. if an endrun message has been created + check_endrun = len_trim(abort_msg) > 0 + if (check_endrun .and. present(output)) then + ! Output the endrun message to + if (output > 0) then + if (present(test_desc)) then + write(output, *) "FAIL: ", trim(test_desc) + end if + write(output, *) trim(abort_msg) + end if + end if + ! Always clear the endrun message + abort_msg = '' + end function check_endrun + + subroutine endrun(message, file, line) + ! Dummy arguments + character(len=*), intent(in) :: message + character(len=*), optional, intent(in) :: file + integer, optional, intent(in) :: line + + if (present(file) .and. present(line)) then + write(abort_msg, '(4a,i0)') trim(message), ' at ', trim(file), ':', line + else if (present(file)) then + write(abort_msg, '(3a)') trim(message), ' at ', trim(file) + else if (present(line)) then + write(abort_msg, '(2a,i0)') trim(message), ' on line ', line + else + write(abort_msg, '(a)') trim(message) + end if - write(6, *) msg - STOP end subroutine endrun + subroutine check_allocate(errcode, subname, fieldname, errmsg, file, line) + ! If is not zero, call endrun with an error message + + ! Dummy arguments + integer, intent(in) :: errcode + character(len=*), intent(in) :: subname + character(len=*), intent(in) :: fieldname + character(len=*), optional, intent(in) :: errmsg + character(len=*), optional, intent(in) :: file + integer, optional, intent(in) :: line + ! Local variable + character(len=max_chars) :: abort_msg + + if (errcode /= 0) then + if (present(errmsg)) then + write(abort_msg, '(6a)') trim(subname), ": Allocate of '", & + trim(fieldname), "' failed; '", trim(errmsg), "'" + else + write(abort_msg, '(4a,i0)') trim(subname), ": Allocate of '", & + trim(fieldname), "' failed with code ", errcode + end if + call endrun(abort_msg, file=file, line=line) + end if + + end subroutine check_allocate + end module cam_abortutils diff --git a/test/include/cam_control_mod.F90 b/test/include/cam_control_mod.F90 new file mode 100644 index 00000000..6fe16373 --- /dev/null +++ b/test/include/cam_control_mod.F90 @@ -0,0 +1,50 @@ +module cam_control_mod +!------------------------------------------------------------------------------ +! +! High level control variables. Information received from the driver/coupler is +! stored here. +! +!------------------------------------------------------------------------------ + + use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs, cl=>shr_kind_cl + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + + implicit none + public + save + + ! Public Routines: + ! + ! cam_ctrl_init + ! cam_ctrl_set_orbit + ! cam_ctrl_set_physics_type + + character(len=cl), protected :: caseid ! case ID + character(len=cl), protected :: ctitle ! case title + + logical, protected :: initial_run ! startup mode which only requires a minimal initial file + logical, protected :: restart_run ! continue a previous run; requires a restart file + logical, protected :: branch_run ! branch from a previous run; requires a restart file + + logical, protected :: adiabatic ! true => no physics + logical, protected :: ideal_phys ! true => run Held-Suarez (1994) physics + logical, protected :: kessler_phys ! true => run Kessler physics + logical, protected :: tj2016_phys ! true => run tj2016 physics + logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys + ! or tj2016 + logical, protected :: aqua_planet ! Flag to run model in "aqua planet" mode + logical, protected :: moist_physics ! true => moist physics enabled, i.e., + ! (.not. ideal_phys) .and. (.not. adiabatic) + + logical, protected :: brnch_retain_casename ! true => branch run may use same caseid as + ! the run being branched from + + real(r8), protected :: eccen ! Earth's eccentricity factor (unitless) (typically 0 to 0.1) + real(r8), protected :: obliqr ! Earth's obliquity in radians + real(r8), protected :: lambm0 ! Mean longitude of perihelion at the + ! vernal equinox (radians) + real(r8), protected :: mvelpp ! Earth's moving vernal equinox longitude + ! of perihelion plus pi (radians) +end module cam_control_mod diff --git a/test/include/dtypes.h b/test/include/dtypes.h new file mode 100644 index 00000000..f2e5b000 --- /dev/null +++ b/test/include/dtypes.h @@ -0,0 +1,6 @@ +#define TYPETEXT 100 +#define TYPEREAL 101 +#define TYPEDOUBLE 102 +#define TYPEINT 103 +#define TYPELONG 104 +#define TYPELOGICAL 105 diff --git a/test/include/shr_assert_mod.F90 b/test/include/shr_assert_mod.F90 new file mode 100644 index 00000000..1def7c73 --- /dev/null +++ b/test/include/shr_assert_mod.F90 @@ -0,0 +1,8602 @@ +#include "dtypes.h" +!=================================================== +! DO NOT EDIT THIS FILE, it was generated using /home/user/Projects/CAMDEN/cime/src/externals/genf90/genf90.pl +! Any changes you make to this file may be lost +!=================================================== +module shr_assert_mod + +! Assert subroutines for common debugging operations. + +use shr_kind_mod, only: & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + i4 => shr_kind_i4, & + i8 => shr_kind_i8 + +use shr_sys_mod, only: & + shr_sys_abort + +use shr_log_mod, only: & + shr_log_Unit + +use shr_infnan_mod, only: shr_infnan_isnan + +use shr_strconvert_mod, only: toString + +implicit none +private +save + +! Assert that a logical is true. +public :: shr_assert +public :: shr_assert_all +public :: shr_assert_any + +! Assert that a numerical value satisfies certain constraints. +public :: shr_assert_in_domain + +# 33 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface shr_assert_all + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_1d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_2d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_3d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_4d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_5d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_6d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_7d +end interface + +# 39 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface shr_assert_any + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_1d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_2d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_3d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_4d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_5d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_6d + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_7d +end interface + +# 45 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface shr_assert_in_domain + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_0d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_1d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_2d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_3d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_4d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_5d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_6d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_7d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_0d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_1d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_2d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_3d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_4d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_5d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_6d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_7d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_0d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_1d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_2d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_3d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_4d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_5d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_6d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_7d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_0d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_1d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_2d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_3d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_4d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_5d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_6d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_7d_long +end interface + +! Private utilities. + +# 53 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface print_bad_loc + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_0d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_1d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_2d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_3d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_4d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_5d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_6d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_7d_double + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_0d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_1d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_2d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_3d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_4d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_5d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_6d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_7d_real + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_0d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_1d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_2d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_3d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_4d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_5d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_6d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_7d_int + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_0d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_1d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_2d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_3d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_4d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_5d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_6d_long + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_7d_long +end interface + +# 59 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface find_first_loc + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_0d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_1d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_2d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_3d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_4d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_5d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_6d + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_7d +end interface + +# 64 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +interface within_tolerance + ! TYPE double,real,int,long + module procedure within_tolerance_double + ! TYPE double,real,int,long + module procedure within_tolerance_real + ! TYPE double,real,int,long + module procedure within_tolerance_int + ! TYPE double,real,int,long + module procedure within_tolerance_long +end interface + +# 69 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +contains + +# 71 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + character(len=:), allocatable :: full_msg + + if (.not. var) then + full_msg = 'ERROR' + if (present(file)) then + full_msg = full_msg // ' in ' // trim(file) + if (present(line)) then + full_msg = full_msg // ' at line ' // toString(line) + end if + end if + if (present(msg)) then + full_msg = full_msg // ': ' // msg + end if + call shr_sys_abort(full_msg) + end if + +# 98 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert + +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_1d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_1d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_2d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_2d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_3d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_3d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_4d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_4d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_5d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_5d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_6d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_6d +! DIMS 1,2,3,4,5,6,7 +# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_all_7d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_all_7d + +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_1d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_1d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_2d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_2d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_3d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_3d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_4d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_4d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_5d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_5d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_6d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_6d +! DIMS 1,2,3,4,5,6,7 +# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_any_7d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var(:,:,:,:,:,:,:) + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_any_7d + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_0d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (0 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(0) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,0) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_0d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_1d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (1 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(1) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,1) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_1d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_2d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (2 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(2) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,2) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_2d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_3d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (3 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(3) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,3) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_3d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_4d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (4 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(4) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,4) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_4d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_5d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (5 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(5) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,5) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_5d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_6d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (6 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(6) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,6) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_6d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_7d_double(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (7 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r8), intent(in) :: var(:,:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r8), intent(in), optional :: lt + real(r8), intent(in), optional :: gt + real(r8), intent(in), optional :: le + real(r8), intent(in), optional :: ge + real(r8), intent(in), optional :: eq + real(r8), intent(in), optional :: ne + real(r8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(7) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,7) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_7d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_0d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (0 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(0) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,0) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_0d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_1d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (1 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(1) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,1) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_1d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_2d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (2 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(2) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,2) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_2d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_3d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (3 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(3) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,3) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_3d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_4d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (4 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(4) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,4) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_4d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_5d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (5 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(5) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,5) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_5d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_6d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (6 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(6) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,6) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_6d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_7d_real(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (7 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + real(r4), intent(in) :: var(:,:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + real(r4), intent(in), optional :: lt + real(r4), intent(in), optional :: gt + real(r4), intent(in), optional :: le + real(r4), intent(in), optional :: ge + real(r4), intent(in), optional :: eq + real(r4), intent(in), optional :: ne + real(r4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(7) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + real(r4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,7) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_7d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_0d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (0 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(0) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,0) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_0d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_1d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (1 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(1) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,1) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_1d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_2d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (2 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(2) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,2) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_2d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_3d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (3 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(3) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,3) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_3d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_4d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (4 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(4) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,4) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_4d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_5d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (5 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(5) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,5) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_5d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_6d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (6 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(6) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,6) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_6d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_7d_int(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (7 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i4), intent(in) :: var(:,:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i4), intent(in), optional :: lt + integer(i4), intent(in), optional :: gt + integer(i4), intent(in), optional :: le + integer(i4), intent(in), optional :: ge + integer(i4), intent(in), optional :: eq + integer(i4), intent(in), optional :: ne + integer(i4), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(7) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i4) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,7) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_7d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_0d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (0 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(0) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,0) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_0d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_1d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (1 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(1) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,1) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_1d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_2d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (2 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(2) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,2) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_2d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_3d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (3 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(3) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,3) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_3d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_4d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (4 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(4) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,4) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_4d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_5d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (5 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(5) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,5) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_5d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_6d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (6 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(6) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,6) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_6d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine shr_assert_in_domain_7d_long(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if (7 != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + integer(i8), intent(in) :: var(:,:,:,:,:,:,:) + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + integer(i8), intent(in), optional :: lt + integer(i8), intent(in), optional :: gt + integer(i8), intent(in), optional :: le + integer(i8), intent(in), optional :: ge + integer(i8), intent(in), optional :: eq + integer(i8), intent(in), optional :: ne + integer(i8), intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec(7) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + integer(i8) :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,7) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine shr_assert_in_domain_7d_long + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_0d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var + integer, intent(in) :: loc_vec(0) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (0 != 0) + var(), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_0d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_1d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:) + integer, intent(in) :: loc_vec(1) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (1 != 0) + var(loc_vec(1)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_1d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_2d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:) + integer, intent(in) :: loc_vec(2) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (2 != 0) + var(loc_vec(1),& +loc_vec(2)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_2d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_3d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:,:) + integer, intent(in) :: loc_vec(3) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (3 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_3d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_4d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:,:,:) + integer, intent(in) :: loc_vec(4) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (4 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_4d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_5d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:,:,:,:) + integer, intent(in) :: loc_vec(5) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (5 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_5d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_6d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:,:,:,:,:) + integer, intent(in) :: loc_vec(6) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (6 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_6d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_7d_double(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r8), intent(in) :: var(:,:,:,:,:,:,:) + integer, intent(in) :: loc_vec(7) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (7 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6),& +loc_vec(7)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_7d_double +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_0d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var + integer, intent(in) :: loc_vec(0) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (0 != 0) + var(), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_0d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_1d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:) + integer, intent(in) :: loc_vec(1) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (1 != 0) + var(loc_vec(1)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_1d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_2d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:) + integer, intent(in) :: loc_vec(2) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (2 != 0) + var(loc_vec(1),& +loc_vec(2)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_2d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_3d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:,:) + integer, intent(in) :: loc_vec(3) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (3 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_3d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_4d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:,:,:) + integer, intent(in) :: loc_vec(4) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (4 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_4d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_5d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:,:,:,:) + integer, intent(in) :: loc_vec(5) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (5 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_5d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_6d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:,:,:,:,:) + integer, intent(in) :: loc_vec(6) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (6 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_6d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_7d_real(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + real(r4), intent(in) :: var(:,:,:,:,:,:,:) + integer, intent(in) :: loc_vec(7) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (7 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6),& +loc_vec(7)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_7d_real +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_0d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var + integer, intent(in) :: loc_vec(0) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (0 != 0) + var(), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_0d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_1d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:) + integer, intent(in) :: loc_vec(1) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (1 != 0) + var(loc_vec(1)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_1d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_2d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:) + integer, intent(in) :: loc_vec(2) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (2 != 0) + var(loc_vec(1),& +loc_vec(2)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_2d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_3d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:,:) + integer, intent(in) :: loc_vec(3) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (3 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_3d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_4d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:,:,:) + integer, intent(in) :: loc_vec(4) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (4 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_4d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_5d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:,:,:,:) + integer, intent(in) :: loc_vec(5) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (5 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_5d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_6d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:,:,:,:,:) + integer, intent(in) :: loc_vec(6) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (6 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_6d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_7d_int(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i4), intent(in) :: var(:,:,:,:,:,:,:) + integer, intent(in) :: loc_vec(7) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (7 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6),& +loc_vec(7)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_7d_int +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_0d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var + integer, intent(in) :: loc_vec(0) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (0 != 0) + var(), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_0d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_1d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:) + integer, intent(in) :: loc_vec(1) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (1 != 0) + var(loc_vec(1)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_1d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_2d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:) + integer, intent(in) :: loc_vec(2) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (2 != 0) + var(loc_vec(1),& +loc_vec(2)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_2d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_3d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:,:) + integer, intent(in) :: loc_vec(3) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (3 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_3d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_4d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:,:,:) + integer, intent(in) :: loc_vec(4) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (4 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_4d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_5d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:,:,:,:) + integer, intent(in) :: loc_vec(5) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (5 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_5d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_6d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:,:,:,:,:) + integer, intent(in) :: loc_vec(6) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (6 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_6d_long +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +subroutine print_bad_loc_7d_long(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + integer(i8), intent(in) :: var(:,:,:,:,:,:,:) + integer, intent(in) :: loc_vec(7) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if (7 != 0) + var(loc_vec(1),& +loc_vec(2),& +loc_vec(3),& +loc_vec(4),& +loc_vec(5),& +loc_vec(6),& +loc_vec(7)), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end subroutine print_bad_loc_7d_long + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_0d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask + integer :: loc_vec(0) + +#if (0 != 0) + integer :: flags() + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_0d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_1d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:) + integer :: loc_vec(1) + +#if (1 != 0) + integer :: flags(size(mask,1)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_1d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_2d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:) + integer :: loc_vec(2) + +#if (2 != 0) + integer :: flags(size(mask,1),& +size(mask,2)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_2d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_3d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:,:) + integer :: loc_vec(3) + +#if (3 != 0) + integer :: flags(size(mask,1),& +size(mask,2),& +size(mask,3)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_3d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_4d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:,:,:) + integer :: loc_vec(4) + +#if (4 != 0) + integer :: flags(size(mask,1),& +size(mask,2),& +size(mask,3),& +size(mask,4)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_4d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_5d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:,:,:,:) + integer :: loc_vec(5) + +#if (5 != 0) + integer :: flags(size(mask,1),& +size(mask,2),& +size(mask,3),& +size(mask,4),& +size(mask,5)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_5d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_6d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:,:,:,:,:) + integer :: loc_vec(6) + +#if (6 != 0) + integer :: flags(size(mask,1),& +size(mask,2),& +size(mask,3),& +size(mask,4),& +size(mask,5),& +size(mask,6)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_6d +! DIMS 0,1,2,3,4,5,6,7 +# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +pure function find_first_loc_7d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask(:,:,:,:,:,:,:) + integer :: loc_vec(7) + +#if (7 != 0) + integer :: flags(size(mask,1),& +size(mask,2),& +size(mask,3),& +size(mask,4),& +size(mask,5),& +size(mask,6),& +size(mask,7)) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function find_first_loc_7d + +! TYPE double,real,int,long +# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +elemental function within_tolerance_double(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + real(r8), intent(in) :: expected + real(r8), intent(in) :: actual + real(r8), intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function within_tolerance_double +! TYPE double,real,int,long +# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +elemental function within_tolerance_real(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + real(r4), intent(in) :: expected + real(r4), intent(in) :: actual + real(r4), intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function within_tolerance_real +! TYPE double,real,int,long +# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +elemental function within_tolerance_int(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + integer(i4), intent(in) :: expected + integer(i4), intent(in) :: actual + integer(i4), intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function within_tolerance_int +! TYPE double,real,int,long +# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +elemental function within_tolerance_long(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + integer(i8), intent(in) :: expected + integer(i8), intent(in) :: actual + integer(i8), intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" +end function within_tolerance_long + +end module shr_assert_mod diff --git a/test/include/shr_infnan_mod.F90 b/test/include/shr_infnan_mod.F90 index 8863882d..575838ce 100644 --- a/test/include/shr_infnan_mod.F90 +++ b/test/include/shr_infnan_mod.F90 @@ -1,6 +1,8 @@ -! This file is a stand-in for CIME's shr_infnan_mod.F90.in +#include "dtypes.h" +!=================================================== +! DO NOT EDIT THIS FILE, it was generated using /home/user/Projects/CAMDEN/cime/src/externals/genf90/genf90.pl +! Any changes you make to this file may be lost !=================================================== - ! Flag representing compiler support of Fortran 2003's ! ieee_arithmetic intrinsic module. #if defined CPRIBM || defined CPRPGI || defined CPRINTEL || defined CPRCRAY || defined CPRNAG @@ -69,7 +71,6 @@ module shr_infnan_mod ! Locally defined isnan. #ifndef HAVE_IEEE_ARITHMETIC - interface shr_infnan_isnan ! TYPE double,real module procedure shr_infnan_isnan_double @@ -78,7 +79,6 @@ module shr_infnan_mod end interface #endif - interface shr_infnan_isinf ! TYPE double,real module procedure shr_infnan_isinf_double @@ -86,7 +86,6 @@ module shr_infnan_mod module procedure shr_infnan_isinf_real end interface - interface shr_infnan_isposinf ! TYPE double,real module procedure shr_infnan_isposinf_double @@ -94,7 +93,6 @@ module shr_infnan_mod module procedure shr_infnan_isposinf_real end interface - interface shr_infnan_isneginf ! TYPE double,real module procedure shr_infnan_isneginf_double @@ -122,7 +120,6 @@ module shr_infnan_mod end type shr_infnan_inf_type ! Allow assigning reals to NaN or Inf. - interface assignment(=) ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 @@ -223,13 +220,11 @@ module shr_infnan_mod end interface ! Conversion functions. - interface shr_infnan_to_r8 module procedure nan_r8 module procedure inf_r8 end interface - interface shr_infnan_to_r4 module procedure nan_r4 module procedure inf_r4 @@ -270,7 +265,6 @@ module shr_infnan_mod integer(i8), parameter :: dneginf_pat = ibset(dposinf_pat,bit_size(1_i8)-1) #endif - contains !--------------------------------------------------------------------- @@ -280,24 +274,20 @@ module shr_infnan_mod !--------------------------------------------------------------------- ! TYPE double,real - elemental function shr_infnan_isinf_double(x) result(isinf) real(r8), intent(in) :: x logical :: isinf isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) - end function shr_infnan_isinf_double ! TYPE double,real - elemental function shr_infnan_isinf_real(x) result(isinf) real(r4), intent(in) :: x logical :: isinf isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) - end function shr_infnan_isinf_real #ifdef HAVE_IEEE_ARITHMETIC @@ -309,7 +299,6 @@ end function shr_infnan_isinf_real !--------------------------------------------------------------------- ! TYPE double,real - elemental function shr_infnan_isposinf_double(x) result(isposinf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -320,10 +309,8 @@ elemental function shr_infnan_isposinf_double(x) result(isposinf) isposinf = (ieee_positive_inf == ieee_class(x)) - end function shr_infnan_isposinf_double ! TYPE double,real - elemental function shr_infnan_isposinf_real(x) result(isposinf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -334,11 +321,9 @@ elemental function shr_infnan_isposinf_real(x) result(isposinf) isposinf = (ieee_positive_inf == ieee_class(x)) - end function shr_infnan_isposinf_real ! TYPE double,real - elemental function shr_infnan_isneginf_double(x) result(isneginf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -349,10 +334,8 @@ elemental function shr_infnan_isneginf_double(x) result(isneginf) isneginf = (ieee_negative_inf == ieee_class(x)) - end function shr_infnan_isneginf_double ! TYPE double,real - elemental function shr_infnan_isneginf_real(x) result(isneginf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -363,7 +346,6 @@ elemental function shr_infnan_isneginf_real(x) result(isneginf) isneginf = (ieee_negative_inf == ieee_class(x)) - end function shr_infnan_isneginf_real #else @@ -372,24 +354,20 @@ end function shr_infnan_isneginf_real #ifdef CPRGNU ! NaN testing on gfortran. ! TYPE double,real - elemental function shr_infnan_isnan_double(x) result(is_nan) real(r8), intent(in) :: x logical :: is_nan is_nan = isnan(x) - end function shr_infnan_isnan_double ! TYPE double,real - elemental function shr_infnan_isnan_real(x) result(is_nan) real(r4), intent(in) :: x logical :: is_nan is_nan = isnan(x) - end function shr_infnan_isnan_real ! End GNU section. #endif @@ -400,7 +378,6 @@ end function shr_infnan_isnan_real !--------------------------------------------------------------------- ! TYPE double,real - elemental function shr_infnan_isposinf_double(x) result(isposinf) real(r8), intent(in) :: x logical :: isposinf @@ -412,10 +389,8 @@ elemental function shr_infnan_isposinf_double(x) result(isposinf) isposinf = (x == transfer(posinf_pat,x)) - end function shr_infnan_isposinf_double ! TYPE double,real - elemental function shr_infnan_isposinf_real(x) result(isposinf) real(r4), intent(in) :: x logical :: isposinf @@ -427,11 +402,9 @@ elemental function shr_infnan_isposinf_real(x) result(isposinf) isposinf = (x == transfer(posinf_pat,x)) - end function shr_infnan_isposinf_real ! TYPE double,real - elemental function shr_infnan_isneginf_double(x) result(isneginf) real(r8), intent(in) :: x logical :: isneginf @@ -443,10 +416,8 @@ elemental function shr_infnan_isneginf_double(x) result(isneginf) isneginf = (x == transfer(neginf_pat,x)) - end function shr_infnan_isneginf_double ! TYPE double,real - elemental function shr_infnan_isneginf_real(x) result(isneginf) real(r4), intent(in) :: x logical :: isneginf @@ -458,7 +429,6 @@ elemental function shr_infnan_isneginf_real(x) result(isneginf) isneginf = (x == transfer(neginf_pat,x)) - end function shr_infnan_isneginf_real ! End ieee_arithmetic conditional. @@ -482,7 +452,6 @@ end function shr_infnan_isneginf_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_0d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -521,11 +490,9 @@ pure subroutine set_nan_0d_double(output, nan) output = tmp - end subroutine set_nan_0d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_1d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -564,11 +531,9 @@ pure subroutine set_nan_1d_double(output, nan) output = tmp - end subroutine set_nan_1d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_2d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -607,11 +572,9 @@ pure subroutine set_nan_2d_double(output, nan) output = tmp - end subroutine set_nan_2d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_3d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -650,11 +613,9 @@ pure subroutine set_nan_3d_double(output, nan) output = tmp - end subroutine set_nan_3d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_4d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -693,11 +654,9 @@ pure subroutine set_nan_4d_double(output, nan) output = tmp - end subroutine set_nan_4d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_5d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -736,11 +695,9 @@ pure subroutine set_nan_5d_double(output, nan) output = tmp - end subroutine set_nan_5d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_6d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -779,11 +736,9 @@ pure subroutine set_nan_6d_double(output, nan) output = tmp - end subroutine set_nan_6d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_7d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -822,11 +777,9 @@ pure subroutine set_nan_7d_double(output, nan) output = tmp - end subroutine set_nan_7d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_0d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -865,11 +818,9 @@ pure subroutine set_nan_0d_real(output, nan) output = tmp - end subroutine set_nan_0d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_1d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -908,11 +859,9 @@ pure subroutine set_nan_1d_real(output, nan) output = tmp - end subroutine set_nan_1d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_2d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -951,11 +900,9 @@ pure subroutine set_nan_2d_real(output, nan) output = tmp - end subroutine set_nan_2d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_3d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -994,11 +941,9 @@ pure subroutine set_nan_3d_real(output, nan) output = tmp - end subroutine set_nan_3d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_4d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1037,11 +982,9 @@ pure subroutine set_nan_4d_real(output, nan) output = tmp - end subroutine set_nan_4d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_5d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1080,11 +1023,9 @@ pure subroutine set_nan_5d_real(output, nan) output = tmp - end subroutine set_nan_5d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_6d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1123,11 +1064,9 @@ pure subroutine set_nan_6d_real(output, nan) output = tmp - end subroutine set_nan_6d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_nan_7d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1166,12 +1105,10 @@ pure subroutine set_nan_7d_real(output, nan) output = tmp - end subroutine set_nan_7d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_0d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1210,11 +1147,9 @@ pure subroutine set_inf_0d_double(output, inf) output = tmp - end subroutine set_inf_0d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_1d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1253,11 +1188,9 @@ pure subroutine set_inf_1d_double(output, inf) output = tmp - end subroutine set_inf_1d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_2d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1296,11 +1229,9 @@ pure subroutine set_inf_2d_double(output, inf) output = tmp - end subroutine set_inf_2d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_3d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1339,11 +1270,9 @@ pure subroutine set_inf_3d_double(output, inf) output = tmp - end subroutine set_inf_3d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_4d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1382,11 +1311,9 @@ pure subroutine set_inf_4d_double(output, inf) output = tmp - end subroutine set_inf_4d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_5d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1425,11 +1352,9 @@ pure subroutine set_inf_5d_double(output, inf) output = tmp - end subroutine set_inf_5d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_6d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1468,11 +1393,9 @@ pure subroutine set_inf_6d_double(output, inf) output = tmp - end subroutine set_inf_6d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_7d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1511,11 +1434,9 @@ pure subroutine set_inf_7d_double(output, inf) output = tmp - end subroutine set_inf_7d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_0d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1554,11 +1475,9 @@ pure subroutine set_inf_0d_real(output, inf) output = tmp - end subroutine set_inf_0d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_1d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1597,11 +1516,9 @@ pure subroutine set_inf_1d_real(output, inf) output = tmp - end subroutine set_inf_1d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_2d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1640,11 +1557,9 @@ pure subroutine set_inf_2d_real(output, inf) output = tmp - end subroutine set_inf_2d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_3d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1683,11 +1598,9 @@ pure subroutine set_inf_3d_real(output, inf) output = tmp - end subroutine set_inf_3d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_4d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1726,11 +1639,9 @@ pure subroutine set_inf_4d_real(output, inf) output = tmp - end subroutine set_inf_4d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_5d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1769,11 +1680,9 @@ pure subroutine set_inf_5d_real(output, inf) output = tmp - end subroutine set_inf_5d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_6d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1812,11 +1721,9 @@ pure subroutine set_inf_6d_real(output, inf) output = tmp - end subroutine set_inf_6d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 - pure subroutine set_inf_7d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1855,7 +1762,6 @@ pure subroutine set_inf_7d_real(output, inf) output = tmp - end subroutine set_inf_7d_real !--------------------------------------------------------------------- @@ -1864,44 +1770,36 @@ end subroutine set_inf_7d_real ! Function methods to get reals from nan/inf types. !--------------------------------------------------------------------- - pure function nan_r8(nan) result(output) class(shr_infnan_nan_type), intent(in) :: nan real(r8) :: output output = nan - end function nan_r8 - pure function nan_r4(nan) result(output) class(shr_infnan_nan_type), intent(in) :: nan real(r4) :: output output = nan - end function nan_r4 - pure function inf_r8(inf) result(output) class(shr_infnan_inf_type), intent(in) :: inf real(r8) :: output output = inf - end function inf_r8 - pure function inf_r4(inf) result(output) class(shr_infnan_inf_type), intent(in) :: inf real(r4) :: output output = inf - end function inf_r4 end module shr_infnan_mod diff --git a/test/include/shr_kind_mod.F90 b/test/include/shr_kind_mod.F90 deleted file mode 100644 index e9e7d170..00000000 --- a/test/include/shr_kind_mod.F90 +++ /dev/null @@ -1,19 +0,0 @@ -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - integer,parameter :: SHR_KIND_CS = 80 ! short char - integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char - integer,parameter :: SHR_KIND_CL = 256 ! long char - integer,parameter :: SHR_KIND_CX = 512 ! extra-long char - integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char - -END MODULE shr_kind_mod diff --git a/test/include/shr_string_mod.F90 b/test/include/shr_string_mod.F90 new file mode 100644 index 00000000..84ba7a32 --- /dev/null +++ b/test/include/shr_string_mod.F90 @@ -0,0 +1,2037 @@ +! !MODULE: shr_string_mod -- string and list methods +! +! !DESCRIPTION: +! General string and specific list method. A list is a single string +! that is delimited by a character forming multiple fields, ie, +! character(len=*) :: mylist = "t:s:u1:v1:u2:v2:taux:tauy" +! The delimiter is called listDel in this module, is default ":", +! but can be set by a call to shr_string_listSetDel. +! +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_string_mod + + ! !USES: +#ifdef NDEBUG +#define SHR_ASSERT(assert, msg) +#define SHR_ASSERT_FL(assert, file, line) +#define SHR_ASSERT_MFL(assert, msg, file, line) +#define SHR_ASSERT_ALL(assert, msg) +#define SHR_ASSERT_ALL_FL(assert, file, line) +#define SHR_ASSERT_ALL_MFL(assert, msg, file, line) +#define SHR_ASSERT_ANY(assert, msg) +#define SHR_ASSERT_ANY_FL(assert, file, line) +#define SHR_ASSERT_ANY_MFL(assert, msg, file, line) +#else +#define SHR_ASSERT(assert, my_msg) call shr_assert(assert, msg=my_msg) +#define SHR_ASSERT_FL(assert, my_file, my_line) call shr_assert(assert, file=my_file, line=my_line) +#define SHR_ASSERT_MFL(assert, my_msg, my_file, my_line) call shr_assert(assert, msg=my_msg, file=my_file, line=my_line) +#define SHR_ASSERT_ALL(assert, my_msg) call shr_assert_all(assert, msg=my_msg) +#define SHR_ASSERT_ALL_FL(assert, my_file, my_line) call shr_assert_all(assert, file=my_file, line=my_line) +#define SHR_ASSERT_ALL_MFL(assert, my_msg, my_file, my_line) call shr_assert_all(assert, msg=my_msg, file=my_file, line=my_line) +#define SHR_ASSERT_ANY(assert, my_msg) call shr_assert_any(assert, msg=my_msg) +#define SHR_ASSERT_ANY_FL(assert, my_file, my_line) call shr_assert_any(assert, file=my_file, line=my_line) +#define SHR_ASSERT_ANY_MFL(assert, my_msg, my_file, my_line) call shr_assert_any(assert, msg=my_msg, file=my_file, line=my_line) +#endif + + use shr_assert_mod + use shr_kind_mod ! F90 kinds + use shr_sys_mod ! shared system calls + use shr_timer_mod, only : shr_timer_get, shr_timer_start, shr_timer_stop + use shr_log_mod, only : errMsg => shr_log_errMsg + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_log_mod, only : s_logunit => shr_log_Unit + + implicit none + private + + ! !PUBLIC TYPES: + + ! no public types + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_string_countChar ! Count number of char in string, fn + public :: shr_string_toUpper ! Convert string to upper-case + public :: shr_string_toLower ! Convert string to lower-case + public :: shr_string_getParentDir ! For a pathname get the parent directory name + public :: shr_string_lastIndex ! Index of last substr in str + public :: shr_string_endIndex ! Index of end of substr in str + public :: shr_string_leftalign_and_convert_tabs ! remove leading white space and convert all tabs to spaces + public :: shr_string_convert_tabs ! Convert all tabs to spaces + public :: shr_string_alphanum ! remove all non alpha-numeric characters + public :: shr_string_betweenTags ! get the substring between the two tags + public :: shr_string_parseCFtunit ! parse CF time units + public :: shr_string_clean ! Set string to all white space + + public :: shr_string_listIsValid ! test for a valid "list" + public :: shr_string_listGetNum ! Get number of fields in list, fn + public :: shr_string_listGetIndex ! Get index of field + public :: shr_string_listGetIndexF ! function version of listGetIndex + public :: shr_string_listGetName ! get k-th field name + public :: shr_string_listIntersect ! get intersection of two field lists + public :: shr_string_listUnion ! get union of two field lists + public :: shr_string_listDiff ! get set difference of two field lists + public :: shr_string_listMerge ! merge two lists to form third + public :: shr_string_listAppend ! append list at end of another + public :: shr_string_listPrepend ! prepend list in front of another + public :: shr_string_listSetDel ! Set field delimiter in lists + public :: shr_string_listGetDel ! Get field delimiter in lists + public :: shr_string_listFromSuffixes! return colon delimited field list + ! given array of suffixes and a base string + public :: shr_string_listCreateField ! return colon delimited field list + ! given number of fields N and a base string + public :: shr_string_listAddSuffix ! add a suffix to every field in a field list + public :: shr_string_setAbort ! set local abort flag + public :: shr_string_setDebug ! set local debug flag + + ! !PUBLIC DATA MEMBERS: + + ! no public data members + + !EOP + + character(len=1) ,save :: listDel = ":" ! note single exec implications + character(len=2) ,save :: listDel2 = "::" ! note single exec implications + logical ,save :: doabort = .true. + integer(SHR_KIND_IN),save :: debug = 0 + + !=============================================================================== +contains + !=============================================================================== + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_countChar -- Count number of occurances of a character + ! + ! !DESCRIPTION: + ! count number of occurances of a single character in a string + ! \newline + ! n = shr\_string\_countChar(string,character) + ! + ! !REVISION HISTORY: + ! 2005-Feb-28 - First version from dshr_bundle + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer function shr_string_countChar(str,char,rc) + + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: str ! string to search + character(1) ,intent(in) :: char ! char to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: count ! counts occurances of char + integer(SHR_KIND_IN) :: n ! generic index + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_countChar) " + character(*),parameter :: F00 = "('(shr_string_countChar) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + count = 0 + do n = 1, len_trim(str) + if (str(n:n) == char) count = count + 1 + end do + shr_string_countChar = count + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_countChar + + !=============================================================================== + !BOP =========================================================================== + ! !IROUTINE: shr_string_toUpper -- Convert string to upper case + ! + ! !DESCRIPTION: + ! Convert the input string to upper-case. + ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. + ! + ! !REVISION HISTORY: + ! 2005-Dec-20 - Move CAM version over to shared code. + ! + ! !INTERFACE: ------------------------------------------------------------------ + + function shr_string_toUpper(str) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to upper case + character(len=len(str)) :: shr_string_toUpper + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: aseq ! ascii collating sequence + integer(SHR_KIND_IN) :: LowerToUpper ! integer to convert case + character(len=1) :: ctmp ! Character temporary + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_toUpper) " + character(*),parameter :: F00 = "('(shr_string_toUpper) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + LowerToUpper = iachar("A") - iachar("a") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & + ctmp = achar(aseq + LowertoUpper) + shr_string_toUpper(i:i) = ctmp + end do + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_toUpper + + !=============================================================================== + !BOP =========================================================================== + ! !IROUTINE: shr_string_toLower -- Convert string to lower case + ! + ! !DESCRIPTION: + ! Convert the input string to lower-case. + ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. + ! + ! !REVISION HISTORY: + ! 2006-Apr-20 - Creation + ! + ! !INTERFACE: ------------------------------------------------------------------ + function shr_string_toLower(str) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: shr_string_toLower + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: aseq ! ascii collating sequence + integer(SHR_KIND_IN) :: UpperToLower ! integer to convert case + character(len=1) :: ctmp ! Character temporary + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_toLower) " + character(*),parameter :: F00 = "('(shr_string_toLower) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + UpperToLower = iachar("a") - iachar("A") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & + ctmp = achar(aseq + UpperToLower) + shr_string_toLower(i:i) = ctmp + end do + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_toLower + + !=============================================================================== + !BOP =========================================================================== + ! !IROUTINE: shr_string_getParentDir -- For pathname get the parent directory name + ! + ! !DESCRIPTION: + ! Get the parent directory name for a pathname. + ! + ! !REVISION HISTORY: + ! 2006-May-09 - Creation + ! + ! !INTERFACE: ------------------------------------------------------------------ + + function shr_string_getParentDir(str) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: shr_string_getParentDir + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: nlen ! Length of string + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_getParentDir) " + character(*),parameter :: F00 = "('(shr_string_getParentDir) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + nlen = len_trim(str) + if ( str(nlen:nlen) == "/" ) nlen = nlen - 1 + i = index( str(1:nlen), "/", back=.true. ) + if ( i == 0 )then + shr_string_getParentDir = str + else + shr_string_getParentDir = str(1:i-1) + end if + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_getParentDir + + !=============================================================================== + !BOP =========================================================================== + ! + ! + ! !IROUTINE: shr_string_lastIndex -- Get index of last substr within string + ! + ! !DESCRIPTION: + ! Get index of last substr within string + ! \newline + ! n = shr\_string\_lastIndex(string,substring) + ! + ! !REVISION HISTORY: + ! 2005-Feb-28 - First version from dshr_domain + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer function shr_string_lastIndex(string,substr,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: substr ! sub-string to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + + !EOP + + !--- local --- + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_lastIndex) " + character(*),parameter :: F00 = "('(shr_string_lastIndex) ',4a)" + + !------------------------------------------------------------------------------- + ! Note: + ! - "new" F90 back option to index function makes this home-grown solution obsolete + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + shr_string_lastIndex = index(string,substr,.true.) + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_lastIndex + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_endIndex -- Get the ending index of substr within string + ! + ! !DESCRIPTION: + ! Get the ending index of substr within string + ! \newline + ! n = shr\_string\_endIndex(string,substring) + ! + ! !REVISION HISTORY: + ! 2005-May-10 - B. Kauffman, first version. + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer function shr_string_endIndex(string,substr,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: substr ! sub-string to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + + !EOP + + !--- local --- + integer(SHR_KIND_IN) :: i ! generic index + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_endIndex) " + character(*),parameter :: F00 = "('(shr_string_endIndex) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! * returns zero if substring not found, uses len_trim() intrinsic + ! * very similar to: i = index(str,substr,back=.true.) + ! * do we need this function? + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + i = index(trim(string),trim(substr)) + if ( i == 0 ) then + shr_string_endIndex = 0 ! substr is not in string + else + shr_string_endIndex = i + len_trim(substr) - 1 + end if + + ! ------------------------------------------------------------------- + ! i = index(trim(string),trim(substr),back=.true.) + ! if (i == len(string)+1) i = 0 + ! shr_string_endIndex = i + ! ------------------------------------------------------------------- + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_endIndex + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_leftalign_and_convert_tabs -- remove leading white space and + ! convert tabs to spaces + ! + ! !DESCRIPTION: + ! Remove leading white space (spaces and tabs) and convert tabs to spaces + ! This even converts tabs in the middle or at the end of the string to spaces + ! \newline + ! call shr\_string\_leftalign_and_convert_tabs(string) + ! + ! !REVISION HISTORY: + ! 2005-Apr-28 - B. Kauffman - First version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_leftalign_and_convert_tabs(str,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: str + integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code + + !EOP + + !----- local ---- + integer(SHR_KIND_IN) :: t01 = 0 ! timer + character, parameter :: tab_char = char(9) + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_leftalign_and_convert_tabs) " + character(*),parameter :: F00 = "('(shr_string_leftalign_and_convert_tabs) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + ! First convert tabs to white space in the string + str = shr_string_convert_tabs(str, rc) + + ! Now remove the leading white space + str = adjustL(str) + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_leftalign_and_convert_tabs + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_convert_tabs -- convert all tabs to spaces + ! + ! !DESCRIPTION: + ! Convert all tabs to spaces in the given string + ! + ! !REVISION HISTORY: + ! 2017-May- - M. Vertenstein + ! + ! !INTERFACE: ------------------------------------------------------------------ + + function shr_string_convert_tabs(str_input,rc) result(str_output) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=*) ,intent(in) :: str_input + integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code + character(len=len(str_input)) :: str_output + !EOP + + !----- local ---- + integer(SHR_KIND_IN) :: inlength, i ! temporaries + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_remove_tabs) " + character(*),parameter :: F00 = "('(shr_string_remove_tabs) ',4a)" + + ! note that tab is achar(9) + inlength = len(str_input) + str_output = '' + do i = 1, inlength + if (str_input(i:i) == achar(9)) then + str_output(i:i) = ' ' + else + str_output(i:i) = str_input(i:i) + end if + end do + + if (present(rc)) rc = 0 + + end function shr_string_convert_tabs + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_alphanum -- remove non alpha numeric characters + ! + ! !DESCRIPTION: + ! Remove all non alpha numeric characters from string + ! \newline + ! call shr\_string\_alphanum(string) + ! + ! !REVISION HISTORY: + ! 2005-Aug-01 - T. Craig - First version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_alphanum(str,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: str + integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code + + !EOP + + !----- local ---- + integer(SHR_KIND_IN) :: n,icnt ! counters + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_alphaNum) " + character(*),parameter :: F00 = "('(shr_string_alphaNum) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + icnt = 0 + do n=1,len_trim(str) + if ((str(n:n) >= 'a' .and. str(n:n) <= 'z') .or. & + (str(n:n) >= 'A' .and. str(n:n) <= 'Z') .or. & + (str(n:n) >= '0' .and. str(n:n) <= '9')) then + icnt = icnt + 1 + str(icnt:icnt) = str(n:n) + endif + enddo + do n=icnt+1,len(str) + str(n:n) = ' ' + enddo + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_alphanum + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_betweenTags -- Get the substring between the two tags. + ! + ! !DESCRIPTION: + ! Get the substring found between the start and end tags. + ! \newline + ! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc) + ! + ! !REVISION HISTORY: + ! 2005-May-11 - B. Kauffman, first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_betweenTags(string,startTag,endTag,substr,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: startTag ! start tag + character(*) ,intent(in) :: endTag ! end tag + character(*) ,intent(out) :: substr ! sub-string between tags + integer(SHR_KIND_IN),intent(out),optional :: rc ! retrun code + + !EOP + + !--- local --- + integer(SHR_KIND_IN) :: iStart ! substring start index + integer(SHR_KIND_IN) :: iEnd ! substring end index + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_betweenTags) " + character(*),parameter :: F00 = "('(shr_string_betweenTags) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! * assumes the leading/trailing white space is not part of start & end tags + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + iStart = shr_string_endIndex(string,trim(adjustL(startTag))) ! end of start tag + iEnd = index(string,trim(adjustL(endTag ))) ! start of end tag + + rCode = 0 + substr = "" + + if (iStart < 1) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: can't find start tag in string" + write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 1 + else if (iEnd < 1) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: can't find end tag in string" + write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 2 + else if ( iEnd <= iStart) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: start tag not before end tag" + write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) + write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 3 + else if ( iStart+1 == iEnd ) then + substr = "" + if (s_loglev > 0) write(s_logunit,F00) "WARNING: zero-length substring found in ",trim(string) + else + substr = string(iStart+1:iEnd-1) + if (len_trim(substr) == 0 .and. s_loglev > 0) & + & write(s_logunit,F00) "WARNING: white-space substring found in ",trim(string) + end if + + if (present(rc)) rc = rCode + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_betweenTags + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_parseCFtunit -- Parse CF time unit + ! + ! !DESCRIPTION: + ! Parse CF time unit into a delta string name and a base time in yyyymmdd + ! and seconds (nearest integer actually). + ! \newline + ! call shr\_string\_parseCFtunit(string,substring) + ! \newline + ! Input string is like "days since 0001-06-15 15:20:45.5 -6:00" + ! - recognizes "days", "hours", "minutes", "seconds" + ! - must have at least yyyy-mm-dd, hh:mm:ss.s is optional + ! - expects a "since" in the string + ! - ignores time zone part + ! + ! !REVISION HISTORY: + ! 2005-May-15 - T. Craig - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_parseCFtunit(string,unit,bdate,bsec,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(out) :: unit ! delta time unit + integer(SHR_KIND_IN),intent(out) :: bdate ! base date yyyymmdd + real(SHR_KIND_R8) ,intent(out) :: bsec ! base seconds + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + + !EOP + + !--- local --- + integer(SHR_KIND_IN) :: i,i1,i2 ! generic index + character(SHR_KIND_CL) :: tbase ! baseline time + character(SHR_KIND_CL) :: lstr ! local string + integer(SHR_KIND_IN) :: yr,mo,da,hr,min ! time stuff + real(SHR_KIND_R8) :: sec ! time stuff + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_parseCFtunit) " + character(*),parameter :: F00 = "('(shr_string_parseCFtunit) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! o assume length of CF-1.0 time attribute char string < SHR_KIND_CL + ! This is a reasonable assumption. + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + unit = 'none' + bdate = 0 + bsec = 0.0_SHR_KIND_R8 + + i = shr_string_lastIndex(string,'days ') + if (i > 0) unit = 'days' + i = shr_string_lastIndex(string,'hours ') + if (i > 0) unit = 'hours' + i = shr_string_lastIndex(string,'minutes ') + if (i > 0) unit = 'minutes' + i = shr_string_lastIndex(string,'seconds ') + if (i > 0) unit = 'seconds' + + if (trim(unit) == 'none') then + write(s_logunit,F00) ' ERROR time unit unknown' + call shr_string_abort(subName//' time unit unknown') + endif + + i = shr_string_lastIndex(string,' since ') + if (i < 1) then + write(s_logunit,F00) ' ERROR since does not appear in unit attribute for time ' + call shr_string_abort(subName//' no since in attr name') + endif + tbase = trim(string(i+6:)) + call shr_string_leftalign_and_convert_tabs(tbase) + + if (debug > 0 .and. s_logunit > 0) then + write(s_logunit,*) trim(subName)//' '//'unit '//trim(unit) + write(s_logunit,*) trim(subName)//' '//'tbase '//trim(tbase) + endif + + yr=0; mo=0; da=0; hr=0; min=0; sec=0 + i1 = 1 + + i2 = index(tbase,'-') - 1 + if(i2<0) goto 200 + lstr = tbase(i1:i2) + + read(lstr,*,ERR=200,END=200) yr + tbase = tbase(i2+2:) + call shr_string_leftalign_and_convert_tabs(tbase) + + i2 = index(tbase,'-') - 1 + if(i2<0) goto 200 + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=200) mo + tbase = tbase(i2+2:) + call shr_string_leftalign_and_convert_tabs(tbase) + + i2 = index(tbase,' ') - 1 + if(i2<0) i2= len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=200) da + tbase = tbase(i2+2:) + call shr_string_leftalign_and_convert_tabs(tbase) + + i2 = index(tbase,':') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) hr + tbase = tbase(i2+2:) + call shr_string_leftalign_and_convert_tabs(tbase) + + i2 = index(tbase,':') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) min + tbase = tbase(i2+2:) + call shr_string_leftalign_and_convert_tabs(tbase) + + i2 = index(tbase,' ') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) sec + +100 continue + if (debug > 0 .and. s_loglev > 0) write(s_logunit,*) trim(subName),'ymdhms:',yr,mo,da,hr,min,sec + + bdate = abs(yr)*10000 + mo*100 + da + if (yr < 0) bdate = -bdate + bsec = real(hr*3600 + min*60,SHR_KIND_R8) + sec + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + return + +200 continue + write(s_logunit,F00) 'ERROR 200 on char num read ' + call shr_string_abort(subName//' ERROR on char num read') + if (debug>1) call shr_timer_stop (t01) + return + + end subroutine shr_string_parseCFtunit + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_clean -- Clean a string, set it to "blank" + ! + ! !DESCRIPTION: + ! Clean a string, set it to blank + ! \newline + ! call shr\_string\_clean(string,rc) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_clean(string,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: string ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_clean) " + character(*),parameter :: F00 = "('(shr_string_clean) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + string = ' ' + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_clean + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listIsValid -- determine whether string is a valid list + ! + ! !DESCRIPTION: + ! Determine whether string is a valid list + ! \newline + ! logical_var = shr\_string\_listIsValid(list,rc) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - B. Kauffman + ! + ! !INTERFACE: ------------------------------------------------------------------ + + logical function shr_string_listIsValid(list,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer (SHR_KIND_IN) :: nChar ! lenth of list + integer (SHR_KIND_IN) :: rCode ! return code + integer (SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listIsValid) " + character(*),parameter :: F00 = "('(shr_string_listIsValid) ',4a)" + + !------------------------------------------------------------------------------- + ! check that the list conforms to the list format + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + shr_string_listIsValid = .true. + + nChar = len_trim(list) + if (nChar < 1) then ! list is an empty string + rCode = 1 + else if ( list(1:1) == listDel ) then ! first char is delimiter + rCode = 2 + else if (list(nChar:nChar) == listDel ) then ! last char is delimiter + rCode = 3 + else if (index(trim(list)," " ) > 0) then ! white-space in a field name + rCode = 4 + else if (index(trim(list),listDel2) > 0) then ! found zero length field + rCode = 5 + end if + + if (rCode /= 0) then + shr_string_listIsValid = .false. + if (s_loglev > 0) write(s_logunit,F00) "WARNING: invalid list = ",trim(list) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_listIsValid + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listGetName -- Get name of k-th field in list + ! + ! !DESCRIPTION: + ! Get name of k-th field in list + ! \newline + ! call shr\_string\_listGetName(list,k,name,rc) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - B. Kauffman + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listGetName(list,k,name,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list ! list/string + integer(SHR_KIND_IN) ,intent(in) :: k ! index of field + character(*) ,intent(out) :: name ! k-th name in list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: i,n ! generic indecies + integer(SHR_KIND_IN) :: kFlds ! number of fields in list + integer(SHR_KIND_IN) :: i0,i1 ! name = list(i0:i1) + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetName) " + character(*),parameter :: F00 = "('(shr_string_listGetName) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + !--- check that this is a valid list --- + if (.not. shr_string_listIsValid(list,rCode) ) then + write(s_logunit,F00) "ERROR: invalid list = ",trim(list) + call shr_string_abort(subName//" ERROR: invalid list = "//trim(list)) + end if + + !--- check that this is a valid index --- + kFlds = shr_string_listGetNum(list) + if (k<1 .or. kFlds1) call shr_timer_stop (t01) + + end subroutine shr_string_listGetName + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listIntersect -- Get intersection of two field lists + ! + ! !DESCRIPTION: + ! Get intersection of two fields lists, write into third list + ! \newline + ! call shr\_string\_listIntersect(list1,list2,listout) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listIntersect(list1,list2,listout,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: nf,n1,n2 ! counters + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listIntersect) " + character(*),parameter :: F00 = "('(shr_string_listIntersect) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + nf = shr_string_listGetNum(list1) + call shr_string_clean(listout) + do n1 = 1,nf + call shr_string_listGetName(list1,n1,name,rCode) + n2 = shr_string_listGetIndexF(list2,name) + if (n2 > 0) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listIntersect + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listUnion -- Get union of two field lists + ! + ! !DESCRIPTION: + ! Get union of two fields lists, write into third list + ! \newline + ! call shr\_string\_listUnion(list1,list2,listout) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listUnion(list1,list2,listout,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: nf,n1,n2 ! counters + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listUnion) " + character(*),parameter :: F00 = "('(shr_string_listUnion) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + call shr_string_clean(listout) + + nf = shr_string_listGetNum(list1) + do n1 = 1,nf + call shr_string_listGetName(list1,n1,name,rCode) + n2 = shr_string_listGetIndexF(listout,name) + if (n2 < 1) then + call shr_string_listAppend(listout,name) + endif + enddo + + nf = shr_string_listGetNum(list2) + do n1 = 1,nf + call shr_string_listGetName(list2,n1,name,rCode) + n2 = shr_string_listGetIndexF(listout,name) + if (n2 < 1) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listUnion + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listDiff -- Get set difference of two field lists + ! + ! !DESCRIPTION: + ! Get set difference of two fields lists, write into third list + ! \newline + ! call shr\_string\_listDiff(list1,list2,listout) + ! \newline + ! listout will contain all elements in list1 but not in list2 + ! + ! !REVISION HISTORY: + ! 2015-April-24 - W. Sacks + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listDiff(list1,list2,listout,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: num_fields, index1, index2 + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listDiff) " + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + num_fields = shr_string_listGetNum(list1) + call shr_string_clean(listout) + do index1 = 1,num_fields + call shr_string_listGetName(list1,index1,name,rCode) + index2 = shr_string_listGetIndexF(list2,name) + if (index2 <= 0) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listDiff + + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listMerge -- Merge lists two list to third + ! + ! !DESCRIPTION: + ! Merge two list to third + ! \newline + ! call shr\_string\_listMerge(list1,list2,listout) + ! call shr\_string\_listMerge(list1,list2,list1) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listMerge(list1,list2,listout,rc) + + implicit none + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + character(len=len(list1)) :: l1 + character(len=len(list2)) :: l2 + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listMerge) " + character(*),parameter :: F00 = "('(shr_string_listMerge) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - no input or output string should be longer than SHR_KIND_CX + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + call shr_string_clean(l1) + call shr_string_clean(l2) + call shr_string_clean(listout) + l1 = trim(list1) + l2 = trim(list2) + call shr_string_leftalign_and_convert_tabs(l1,rCode) + call shr_string_leftalign_and_convert_tabs(l2,rCode) + if (len_trim(l1)+len_trim(l2)+1 > len(listout)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(l1) == 0) then + listout = trim(l2) + else + listout = trim(l1)//":"//trim(l2) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listMerge + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listAppend -- Append one list to another + ! + ! !DESCRIPTION: + ! Append one list to another + ! \newline + ! call shr\_string\_listAppend(list,listadd) + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listAppend(list,listadd,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: list ! list/string + character(*) ,intent(in) :: listadd ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + character(SHR_KIND_CX) :: l1 ! local string + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listAppend) " + character(*),parameter :: F00 = "('(shr_string_listAppend) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - no input or output string should be longer than SHR_KIND_CX + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + !--- make sure temp string is large enough --- + if (len(l1) < len_trim(listAdd)) then + call shr_string_abort(subName//'ERROR: temp string not large enough') + end if + + call shr_string_clean(l1) + l1 = trim(listadd) + call shr_string_leftalign_and_convert_tabs(l1,rCode) + if (len_trim(list)+len_trim(l1)+1 > len(list)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(list) == 0) then + list = trim(l1) + else + list = trim(list)//":"//trim(l1) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listAppend + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listPrepend -- Prepend one list to another + ! + ! !DESCRIPTION: + ! Prepend one list to another + ! \newline + ! call shr\_string\_listPrepend(listadd,list) + ! \newline + ! results in listadd:list + ! + ! !REVISION HISTORY: + ! 2005-May-05 - T. Craig + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listPrepend(listadd,list,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: listadd ! list/string + character(*) ,intent(inout) :: list ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + + !EOP + + !----- local ----- + character(SHR_KIND_CX) :: l1 ! local string + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listPrepend) " + character(*),parameter :: F00 = "('(shr_string_listPrepend) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - no input or output string should be longer than SHR_KIND_CX + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + !--- make sure temp string is large enough --- + if (len(l1) < len_trim(listAdd)) then + call shr_string_abort(subName//'ERROR: temp string not large enough') + end if + + call shr_string_clean(l1) + l1 = trim(listadd) + call shr_string_leftalign_and_convert_tabs(l1,rCode) + call shr_string_leftalign_and_convert_tabs(list,rCode) + if (len_trim(list)+len_trim(l1)+1 > len(list)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(l1) == 0) then + list = trim(list) + else + list = trim(l1)//":"//trim(list) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listPrepend + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listGetIndexF -- Get index of field in string + ! + ! !DESCRIPTION: + ! Get index of field in string + ! \newline + ! k = shr\_string\_listGetIndex(str,"taux") + ! + ! !REVISION HISTORY: + ! 2005-Feb-28 - B. Kauffman and J. Schramm - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer function shr_string_listGetIndexF(string,fldStr) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: string ! string + character(*),intent(in) :: fldStr ! name of field + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: k ! local index variable + integer(SHR_KIND_IN) :: rc ! error code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetIndexF) " + character(*),parameter :: F00 = "('(shr_string_listGetIndexF) ',4a)" + + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + call shr_string_listGetIndex(string,fldStr,k,print=.false.,rc=rc) + shr_string_listGetIndexF = k + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_listGetIndexF + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listGetIndex -- Get index of field in string + ! + ! !DESCRIPTION: + ! Get index of field in string + ! \newline + ! call shr\_string\_listGetIndex(str,"taux",k,rc) + ! + ! !REVISION HISTORY: + ! 2005-Feb-28 - B. Kauffman and J. Schramm - first version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listGetIndex(string,fldStr,kFld,print,rc) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string + character(*) ,intent(in) :: fldStr ! name of field + integer(SHR_KIND_IN),intent(out) :: kFld ! index of field + logical ,intent(in) ,optional :: print ! print switch + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! index for colon position + integer(SHR_KIND_IN) :: k ! index for field name position + integer(SHR_KIND_IN) :: nFields ! number of fields in a string + integer(SHR_KIND_IN) :: i0,i1 ! fldStr == string(i0,i1) ?? + integer(SHR_KIND_IN) :: j0,j1 ! fldStr == string(j0,j1) ?? + logical :: found ! T => field found in fieldNames + logical :: lprint ! local print flag + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetIndex) " + character(*),parameter :: F00 = "('(shr_string_listGetIndex) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - searching from both ends of the list at the same time seems to be 20% faster + ! but I'm not sure why (B. Kauffman, Feb 2007) + ! - I commented out sanity check to a little gain speed (B. Kauffman, Mar 2007) + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + if (present(rc)) rc = 0 + + lprint = .false. + if (present(print)) lprint = print + + !--- confirm proper size of input data --- + if (len_trim(fldStr) < 1) then + if (lprint) write(s_logunit,F00) "ERROR: input field name has 0 length" + call shr_string_abort(subName//"invalid field name") + end if + + !--- search for field name in string's list of fields --- + found = .false. + kFld = 0 + i0 = 1 ! ?? fldStr == string(i0:i1) ?? + i1 = -1 + j0 = -1 ! ?? fldStr == string(j0:j1) ?? + j1 = len_trim(string) + nFields = shr_string_listGetNum(string) + do k = 1,nFields + !-------------------------------------------------------- + ! search from end of list to end of list + !-------------------------------------------------------- + !--- get end index of of field number k --- + n = index(string(i0:len_trim(string)),listDel) + if (n > 0) then + i1 = i0 + n - 2 ! *not* the last field name in fieldNames + else + i1 = len_trim(string) ! this is the last field name in fieldNames + endif + !--- sanity check --- + ! if ((k 0)) then + ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") + ! end if + !--- is it a match? --- + if (trim(fldStr) == string(i0:i1)) then + found = .true. + kFld = k + exit + endif + i0 = i1 + 2 ! start index for next iteration + !-------------------------------------------------------- + ! search from end of list to start of list + !-------------------------------------------------------- + !--- get start index of field number (nFields + 1 - k ) --- + n = index(string(1:j1),listDel,back=.true.) + j0 = n + 1 ! n==0 => the first field name in fieldNames + !--- sanity check --- + ! if ((k 0)) then + ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") + ! end if + !--- is it a match? --- + if (trim(fldStr) == string(j0:j1)) then + found = .true. + kFld = nFields + 1 - k + exit + endif + j1 = j0 - 2 ! end index for next iteration + !-------------------------------------------------------- + ! exit if all field names have been checked + !-------------------------------------------------------- + if (2*k >= nFields) exit + end do + + !--- not finding a field is not a fatal error --- + if (.not. found) then + kFld = 0 + if (lprint .and. s_loglev > 0) write(s_logunit,F00) "FYI: field ",trim(fldStr)," not found in list ",trim(string) + if (present(rc)) rc = 1 + end if + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listGetIndex + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listGetNum -- get number of fields in a string list + ! + ! !DESCRIPTION: + ! return number of fields in string list + ! + ! !REVISION HISTORY: + ! 2005-Apr-28 - T. Craig - First version + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer function shr_string_listGetNum(str) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: str ! string to search + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: count ! counts occurances of char + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetNum) " + character(*),parameter :: F00 = "('(shr_string_listGetNum) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + shr_string_listGetNum = 0 + + if (len_trim(str) > 0) then + count = shr_string_countChar(str,listDel) + shr_string_listGetNum = count + 1 + endif + + if (debug>1) call shr_timer_stop (t01) + + end function shr_string_listGetNum + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listSetDel -- Set list delimiter character + ! + ! !DESCRIPTION: + ! Set field delimiter character in lists + ! \newline + ! call shr\_string\_listSetDel(":") + ! + ! !REVISION HISTORY: + ! 2005-Apr-30 - T. Craig - first prototype + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listSetDel(cflag) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=1),intent(in) :: cflag + + !EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listSetDel) " + character(*),parameter :: F00 = "('(shr_string_listSetDel) ',a) " + + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) 'changing listDel from '//trim(listDel)//' to '//trim(cflag) + listDel = trim(cflag) + listDel2 = listDel//listDel + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listSetDel + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_listGetDel -- Get list delimiter character + ! + ! !DESCRIPTION: + ! Get field delimiter character in lists + ! \newline + ! call shr\_string\_listGetDel(del) + ! + ! !REVISION HISTORY: + ! 2005-May-15 - T. Craig - first prototype + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_listGetDel(del) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(out) :: del + + !EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listGetDel) " + character(*),parameter :: F00 = "('(shr_string_listGetDel) ',a) " + + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + del = trim(listDel) + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_listGetDel + + !=============================================================================== + ! + ! shr_string_listFromSuffixes + ! + ! Returns a string of colon delimited fields given an array of suffixes and a base string + ! + ! given suffixes = ['_s1', '_s2', '_s3'] and strBase = 'foo', returns: + ! 'foo_s1:foo_s2:foo_s3' + ! + !=============================================================================== + function shr_string_listFromSuffixes( suffixes, strBase ) result ( retString ) + + character(len=*), intent(in) :: suffixes(:) + character(len=*), intent(in) :: strBase + character(len=:), allocatable :: retString + + integer :: nfields + integer :: i + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + character(len=*), parameter :: subName = "(shr_string_listFromSuffixes) " + + !------------------------------------------------------------------------------- + + if ( debug > 1 .and. t01 < 1 ) call shr_timer_get( t01,subName ) + if ( debug > 1 ) call shr_timer_start( t01 ) + + nfields = size(suffixes) + retString = trim(strBase) // suffixes(1) + do i = 2, nfields + retString = trim(retString) // ':' // trim(strBase) // suffixes(i) + end do + + if ( debug > 1 ) call shr_timer_stop ( t01 ) + + end function shr_string_listFromSuffixes + + !=============================================================================== + ! + ! shr_string_listCreateField + ! + ! Returns a string of colon delimited fields for use in shr_strdata_create + ! arguments, fldListFile and fldListModel. + ! Use to create actual args for shr_strdata_create (fldListFile and + ! flidListModel). + ! + ! This works for numFields up to 999. Modify the string write if you want + ! more range. + ! + ! retString = shr_string_listCreateField(numFields, strBase) + ! given numFields = 5 and strBase = LAI, returns: + ! LAI_1:LAI_2:LAI_3:LAI_4:LAI_5 + ! + !=============================================================================== + function shr_string_listCreateField( numFields, strBase ) result ( retString ) + + implicit none + + integer(SHR_KIND_IN), intent(in) :: numFields ! number of fields + character(len=*) , intent(in) :: strBase ! input string base + character(SHR_KIND_CXX) :: retString ! colon delimited field list + + integer :: idx ! index for looping over numFields + integer(SHR_KIND_IN) :: t01 = 0 ! timer + character(SHR_KIND_CX) :: tmpString ! temporary + character(SHR_KIND_CX) :: intAsChar ! temporary + character(1), parameter :: colonStr = ':' + character(1), parameter :: underStr = '_' + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listCreateField) " + character(*),parameter :: F00 = "('(shr_string_listCreateField) ',a) " + + !------------------------------------------------------------------------------- + + if ( debug > 1 .and. t01 < 1 ) call shr_timer_get( t01,subName ) + if ( debug > 1 ) call shr_timer_start( t01 ) + + ! + ! this assert isn't that accurate since it counts all integers as being one + ! digit, but it should catch most errors and under rather than overestimates + ! +#ifdef DEBUG + call shr_assert((((len(strBase) + 3) * numFields) <= 1024), & + file=__FILE__, line=__LINE__) +#endif + retString = '' + do idx = 1,numFields + + ! reset temps per numField + intAsChar = '' + tmpString = '' + + ! string conversion based on 1,2,3 digits + if ( idx < 10 ) then + write(intAsChar, "(I1)") idx + else if ( idx >= 10 .and. idx < 100 ) then + write(intAsChar, "(I2)") idx + else + write(intAsChar, "(I3)") idx + end if + + tmpString = trim(StrBase)//trim(underStr)//trim(intAsChar) + + if ( idx > 1 ) then + tmpString = trim(colonStr)//trim(tmpString) + end if + + retString = trim(retString)//trim(tmpString) + + end do + + if ( debug > 1 ) call shr_timer_stop ( t01 ) + + end function shr_string_listCreateField + + !=============================================================================== + ! + ! shr_string_listAddSuffix + ! + ! Given an existing list and a suffix, returns a new list with that suffix added to the + ! end of every field in the list. + ! + ! call shr_string_listAddSuffix('a:b:c', '00', new_list) + ! gives new_list = 'a00:b00:c00' + ! + !=============================================================================== + subroutine shr_string_listAddSuffix(list, suffix, new_list) + + implicit none + + character(len=*), intent(in) :: list + character(len=*), intent(in) :: suffix + character(len=*), intent(out) :: new_list + + integer :: num_fields + integer :: field_num + character(SHR_KIND_CS) :: this_field + character(len(this_field) + len(suffix)) :: this_field_with_suffix + character(len(new_list)) :: temp_list + + num_fields = shr_string_listGetNum(list) + new_list = ' ' + + do field_num = 1, num_fields + call shr_string_listGetName(list, field_num, this_field) + this_field_with_suffix = trim(this_field) // suffix + temp_list = new_list + call shr_string_listMerge(temp_list, this_field_with_suffix, new_list) + end do + end subroutine shr_string_listAddSuffix + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_setAbort -- Set local shr_string abort flag + ! + ! !DESCRIPTION: + ! Set local shr_string abort flag, true = abort, false = print and continue + ! \newline + ! call shr\_string\_setAbort(.false.) + ! + ! !REVISION HISTORY: + ! 2005-Apr-30 - T. Craig - first prototype + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_setAbort(flag) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + + !EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_setAbort) " + character(*),parameter :: F00 = "('(shr_string_setAbort) ',a) " + + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + if (debug > 0 .and. s_loglev > 0) then + if (flag) then + write(s_logunit,F00) 'setting abort to true' + else + write(s_logunit,F00) 'setting abort to false' + endif + endif + + doabort = flag + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_setAbort + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_string_setDebug -- Set local shr_string debug level + ! + ! !DESCRIPTION: + ! Set local shr_string debug level, 0 = production + ! \newline + ! call shr\_string\_setDebug(2) + ! + ! !REVISION HISTORY: + ! 2005-Apr-30 - T. Craig - first prototype + ! + ! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_string_setDebug(iFlag) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: iFlag ! requested debug level + + !EOP + + !--- local --- + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_setDebug) " + character(*),parameter :: F00 = "('(shr_string_setDebug) ',a) " + character(*),parameter :: F01 = "('(shr_string_setDebug) ',a,i3,a,i3) " + + !------------------------------------------------------------------------------- + ! NTOE: write statement can be expensive if called many times. + !------------------------------------------------------------------------------- + + if (iFlag>1 .and. t01<1) call shr_timer_get(t01,subName) + if (iFlag>1) call shr_timer_start(t01) + + ! if (s_loglev > 0) write(s_logunit,F01) 'changing debug level from ',debug,' to ',iflag + debug = iFlag + + if (iFlag>1) call shr_timer_stop (t01) + + end subroutine shr_string_setDebug + + !=============================================================================== + !=============================================================================== + + subroutine shr_string_abort(string) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),optional,intent(in) :: string + + !EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- local --- + character(SHR_KIND_CX) :: lstring + character(*),parameter :: subName = "(shr_string_abort)" + character(*),parameter :: F00 = "('(shr_string_abort) ',a)" + + !------------------------------------------------------------------------------- + ! NOTE: + ! - no input or output string should be longer than SHR_KIND_CX + !------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + lstring = '' + if (present(string)) lstring = string + + if (doabort) then + call shr_sys_abort(trim(lstring)) + else + write(s_logunit,F00) ' no abort:'//trim(lstring) + endif + + if (debug>1) call shr_timer_stop (t01) + + end subroutine shr_string_abort + + !=============================================================================== + !=============================================================================== + +end module shr_string_mod diff --git a/test/include/spmd_utils.F90 b/test/include/spmd_utils.F90 index c827ac56..7ba9bb2b 100644 --- a/test/include/spmd_utils.F90 +++ b/test/include/spmd_utils.F90 @@ -1,11 +1,14 @@ module spmd_utils + use mpi, only: MPI_COMM_WORLD + implicit none private - integer, parameter, public :: masterprocid = 0 + integer, parameter, public :: mpicom = MPI_COMM_WORLD integer, parameter, public :: iam = 0 integer, parameter, public :: npes = 1 logical, parameter, public :: masterproc = .true. + integer, parameter, public :: masterprocid = 0 end module spmd_utils diff --git a/test/include/time_manager.F90 b/test/include/time_manager.F90 new file mode 100644 index 00000000..5e5fdaa6 --- /dev/null +++ b/test/include/time_manager.F90 @@ -0,0 +1,312 @@ +module time_manager + + ! Provide CAM specific time management. This is a wrapper layer for the ESMF + ! time manager utility. + ! This test version skips any ESMF call + + use shr_string_mod, only: to_upper => shr_string_toUpper + use shr_kind_mod, only: r8 => shr_kind_r8, SHR_KIND_CS + use spmd_utils, only: masterproc + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + + implicit none + private + save + +! Public methods + +public ::& + timemgr_init, &! time manager initialization + advance_timestep, &! increment the clocks current time + get_step_size, &! return step size in seconds + get_nstep, &! return timestep number + get_curr_date, &! return date components at end of current timestep + get_prev_date, &! return date components at beginning of current timestep + get_start_date, &! return components of the start date + get_ref_date, &! return components of the reference date + get_perp_date, &! return components of the perpetual date, and current time of day + get_curr_time, &! return components of elapsed time since reference date at end of current timestep + get_prev_time, &! return components of elapsed time since reference date at beg of current timestep + is_first_step, &! return true on first step of initial run + is_first_restart_step ! return true on first step of restart or branch run + +! Private module data + +integer, parameter :: uninit_int = -999999999 + +integer :: dtime = uninit_int ! timestep in seconds + +character(len=32) :: calendar ! Calendar type +logical :: tm_first_restart_step = .false. ! true for first step of a restart or branch run +logical :: tm_perp_calendar = .false. ! true when using perpetual calendar + +!========================================================================================= +contains +!========================================================================================= + +subroutine timemgr_init( & + dtime_in, calendar_in, start_ymd, start_tod, ref_ymd, & + ref_tod, stop_ymd, stop_tod, curr_ymd, curr_tod, & + perpetual_run, perpetual_ymd, initial_run) + + ! Initialize the time manager. + + ! Arguments + integer, intent(in) :: dtime_in ! Coupling period (sec) + character(len=*), intent(IN) :: calendar_in ! Calendar type + integer, intent(IN) :: start_ymd ! Start date (YYYYMMDD) + integer, intent(IN) :: start_tod ! Start time of day (sec) + integer, intent(IN) :: ref_ymd ! Reference date (YYYYMMDD) + integer, intent(IN) :: ref_tod ! Reference time of day (sec) + integer, intent(IN) :: stop_ymd ! Stop date (YYYYMMDD) + integer, intent(IN) :: stop_tod ! Stop time of day (sec) + integer, intent(IN) :: curr_ymd ! current date (YYYYMMDD) + integer, intent(IN) :: curr_tod ! current time of day (sec) + logical, intent(IN) :: perpetual_run ! If in perpetual mode or not + integer, intent(IN) :: perpetual_ymd ! Perpetual date (YYYYMMDD) + logical, intent(in) :: initial_run ! true => initial (or startup) run + + +end subroutine timemgr_init +!========================================================================================= + +subroutine advance_timestep() + +! Increment the timestep number. + +! Local variables + character(len=*), parameter :: sub = 'advance_timestep' + integer :: rc +!----------------------------------------------------------------------------------------- + + tm_first_restart_step = .false. + +end subroutine advance_timestep +!========================================================================================= + +integer function get_step_size() + +! Return the step size in seconds. + +! Local variables + character(len=*), parameter :: sub = 'get_step_size' + integer :: rc +!----------------------------------------------------------------------------------------- + + rc = 1800 + +end function get_step_size +!========================================================================================= + +integer function get_nstep() + +! Return the timestep number. + +! Local variables + character(len=*), parameter :: sub = 'get_nstep' + integer :: rc +!----------------------------------------------------------------------------------------- + + get_nstep = 1 + +end function get_nstep +!========================================================================================= + +subroutine get_curr_date(yr, mon, day, tod, offset) + +! Return date components valid at end of current timestep with an optional +! offset (positive or negative) in seconds. + +! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + integer, optional, intent(in) :: offset ! Offset from current time in seconds. + ! Positive for future times, negative + ! for previous times. + +! Local variables + character(len=*), parameter :: sub = 'get_curr_date' + integer :: rc +!----------------------------------------------------------------------------------------- + + yr = 101 + mon = 1 + day = 1 + tod = 0 + +end subroutine get_curr_date +!========================================================================================= + +subroutine get_perp_date(yr, mon, day, tod, offset) + +! Return time of day valid at end of current timestep and the components +! of the perpetual date (with an optional offset (positive or negative) in seconds. + +! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + integer, optional, intent(in) :: offset ! Offset from current time in seconds. + ! Positive for future times, negative + ! for previous times. + +! Local variables + character(len=*), parameter :: sub = 'get_perp_date' + integer :: rc + + yr = 1 + mon = 1 + day = 1 + tod = 0 + +end subroutine get_perp_date +!========================================================================================= + +subroutine get_prev_date(yr, mon, day, tod) + +! Return date components valid at beginning of current timestep. + +! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + yr = 100 + mon = 12 + day = 31 + tod = 84600 + +end subroutine get_prev_date +!========================================================================================= + +subroutine get_start_date(yr, mon, day, tod) + +! Return date components valid at beginning of initial run. + +! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + +! Local variables + character(len=*), parameter :: sub = 'get_start_date' + integer :: rc +!----------------------------------------------------------------------------------------- + + call get_curr_date(yr, mon, day, tod) + +end subroutine get_start_date +!========================================================================================= + +subroutine get_ref_date(yr, mon, day, tod) + +! Return date components of the reference date. + +! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + +! Local variables + character(len=*), parameter :: sub = 'get_ref_date' + integer :: rc +!----------------------------------------------------------------------------------------- + + call get_curr_date(yr, mon, day, tod) + +end subroutine get_ref_date +!========================================================================================= + +subroutine get_curr_time(days, seconds) + +! Return time components valid at end of current timestep. +! Current time is the time interval between the current date and the reference date. + +! Arguments + integer, intent(out) ::& + days, &! number of whole days in time interval + seconds ! remaining seconds in time interval + +! Local variables + character(len=*), parameter :: sub = 'get_curr_time' + integer :: rc + + days = 0 + seconds = 0 + +end subroutine get_curr_time +!========================================================================================= + +subroutine get_prev_time(days, seconds) + +! Return time components valid at beg of current timestep. +! prev time is the time interval between the prev date and the reference date. + +! Arguments + integer, intent(out) ::& + days, &! number of whole days in time interval + seconds ! remaining seconds in time interval + +! Local variables + character(len=*), parameter :: sub = 'get_prev_time' + integer :: rc +!----------------------------------------------------------------------------------------- + + days = 0 + seconds = 0 + +end subroutine get_prev_time + +logical function is_first_step() + +! Return true on first step of initial run only. + +! Local variables + character(len=*), parameter :: sub = 'is_first_step' + integer :: rc +!----------------------------------------------------------------------------------------- + + is_first_step = .true. + +end function is_first_step +!========================================================================================= + +logical function is_first_restart_step() + +! Return true on first step of restart run only. + +!----------------------------------------------------------------------------------------- + + is_first_restart_step = .false. + +end function is_first_restart_step +!========================================================================================= + +logical function is_last_step() + +! Return true on last timestep. + +! Local variables + character(len=*), parameter :: sub = 'is_last_step' + integer :: rc +!----------------------------------------------------------------------------------------- + + is_last_step = .false. + +end function is_last_step + +end module time_manager diff --git a/test/unit/sample_files/hist_config_files/amwg_hist_config b/test/unit/sample_files/hist_config_files/amwg_hist_config new file mode 100644 index 00000000..8b04d506 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/amwg_hist_config @@ -0,0 +1,17 @@ +hist_max_frames: 1 +hist_output_frequency: monthly +hist_precision: REAL32 +!hist_output_levels: IPCC_PRESSURE_LEVELS + +! ADF mean +!hist_diag_file: adf_mean_config +! Radiation +hist_diag_file: rad_config +! Gravity wave +!hist_diag_file: grav_wav_config +! Turbulent mountain stress +hist_add_avg_fields: TAUTMSX, TAUTMSY +! Modal aerosol optics +hist_add_avg_fields: AODDUST1, AODDUST3, AODDUST, AODVIS +! ndrop +hist_add_avg_fields: CCN3 diff --git a/test/unit/sample_files/hist_config_files/atm_in_flat b/test/unit/sample_files/hist_config_files/atm_in_flat new file mode 100644 index 00000000..ae0caee9 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/atm_in_flat @@ -0,0 +1,29 @@ + +&hist_config_arrays_nl + hist_num_inst_fields = 3 + hist_num_avg_fields = 3 + hist_num_min_fields = 3 + hist_num_max_fields = 2 + hist_num_var_fields = 2 +/ + +&hist_file_config_nl + hist_volume = 'h1' + hist_avg_fields = 'MOE ', 'LARRY', 'CURLY' + hist_min_fields = 'mouse', 'bin ', 'gin ' + hist_max_fields = 'Skirt', 'Mad ' + hist_var_fields = 'std', 'stp' + hist_max_frames = 30 + hist_output_frequency = '14*hours' + hist_precision = 'REAL32' + hist_file_type = 'history' +/ + +&hist_file_config_nl + hist_volume = 'h3' + hist_inst_fields = 'T', 'U', 'V' + hist_max_frames = 24 + hist_output_frequency = '2*nsteps' + hist_precision = 'REAL64' + hist_file_type = 'history' +/ diff --git a/test/unit/sample_files/hist_config_files/atm_in_multi b/test/unit/sample_files/hist_config_files/atm_in_multi new file mode 100644 index 00000000..3b5cb58c --- /dev/null +++ b/test/unit/sample_files/hist_config_files/atm_in_multi @@ -0,0 +1,68 @@ + +&hist_config_arrays_nl + hist_num_inst_fields = 3 + hist_num_avg_fields = 258 + hist_num_min_fields = 0 + hist_num_max_fields = 0 + hist_num_var_fields = 0 +/ + +&hist_file_config_nl + hist_volume = 'h0' + hist_avg_fields = 'SOLIN ', 'SOLIN_d1 ', 'SOLIN_d2 ', 'SOLIN_d3 ', 'SOLIN_d4 ', 'SOLIN_d5 ', + 'SOLIN_d6 ', 'SOLIN_d7 ', 'SOLIN_d8 ', 'SOLIN_d9 ', 'SOLIN_d10 ', 'QRS ', + 'QRS_d1 ', 'QRS_d2 ', 'QRS_d3 ', 'QRS_d4 ', 'QRS_d5 ', 'QRS_d6 ', + 'QRS_d7 ', 'QRS_d8 ', 'QRS_d9 ', 'QRS_d10 ', 'FSNT ', 'FSNT_d1 ', + 'FSNT_d2 ', 'FSNT_d3 ', 'FSNT_d4 ', 'FSNT_d5 ', 'FSNT_d6 ', 'FSNT_d7 ', + 'FSNT_d8 ', 'FSNT_d9 ', 'FSNT_d10 ', 'FSNTC ', 'FSNTC_d1 ', 'FSNTC_d2 ', + 'FSNTC_d3 ', 'FSNTC_d4 ', 'FSNTC_d5 ', 'FSNTC_d6 ', 'FSNTC_d7 ', 'FSNTC_d8 ', + 'FSNTC_d9 ', 'FSNTC_d10 ', 'FSNTOA ', 'FSNTOA_d1 ', 'FSNTOA_d2 ', 'FSNTOA_d3 ', + 'FSNTOA_d4 ', 'FSNTOA_d5 ', 'FSNTOA_d6 ', 'FSNTOA_d7 ', 'FSNTOA_d8 ', 'FSNTOA_d9 ', + 'FSNTOA_d10 ', 'FSNTOAC ', 'FSNTOAC_d1 ', 'FSNTOAC_d2 ', 'FSNTOAC_d3 ', 'FSNTOAC_d4 ', + 'FSNTOAC_d5 ', 'FSNTOAC_d6 ', 'FSNTOAC_d7 ', 'FSNTOAC_d8 ', 'FSNTOAC_d9 ', 'FSNTOAC_d10', + 'SWCF ', 'SWCF_d1 ', 'SWCF_d2 ', 'SWCF_d3 ', 'SWCF_d4 ', 'SWCF_d5 ', + 'SWCF_d6 ', 'SWCF_d7 ', 'SWCF_d8 ', 'SWCF_d9 ', 'SWCF_d10 ', 'FSNS ', + 'FSNS_d1 ', 'FSNS_d2 ', 'FSNS_d3 ', 'FSNS_d4 ', 'FSNS_d5 ', 'FSNS_d6 ', + 'FSNS_d7 ', 'FSNS_d8 ', 'FSNS_d9 ', 'FSNS_d10 ', 'FSNSC ', 'FSNSC_d1 ', + 'FSNSC_d2 ', 'FSNSC_d3 ', 'FSNSC_d4 ', 'FSNSC_d5 ', 'FSNSC_d6 ', 'FSNSC_d7 ', + 'FSNSC_d8 ', 'FSNSC_d9 ', 'FSNSC_d10 ', 'FSUTOA ', 'FSUTOA_d1 ', 'FSUTOA_d2 ', + 'FSUTOA_d3 ', 'FSUTOA_d4 ', 'FSUTOA_d5 ', 'FSUTOA_d6 ', 'FSUTOA_d7 ', 'FSUTOA_d8 ', + 'FSUTOA_d9 ', 'FSUTOA_d10 ', 'FSDSC ', 'FSDSC_d1 ', 'FSDSC_d2 ', 'FSDSC_d3 ', + 'FSDSC_d4 ', 'FSDSC_d5 ', 'FSDSC_d6 ', 'FSDSC_d7 ', 'FSDSC_d8 ', 'FSDSC_d9 ', + 'FSDSC_d10 ', 'FSDS ', 'FSDS_d1 ', 'FSDS_d2 ', 'FSDS_d3 ', 'FSDS_d4 ', + 'FSDS_d5 ', 'FSDS_d6 ', 'FSDS_d7 ', 'FSDS_d8 ', 'FSDS_d9 ', 'FSDS_d10 ', + 'QRL ', 'QRL_d1 ', 'QRL_d2 ', 'QRL_d3 ', 'QRL_d4 ', 'QRL_d5 ', + 'QRL_d6 ', 'QRL_d7 ', 'QRL_d8 ', 'QRL_d9 ', 'QRL_d10 ', 'FLNT ', + 'FLNT_d1 ', 'FLNT_d2 ', 'FLNT_d3 ', 'FLNT_d4 ', 'FLNT_d5 ', 'FLNT_d6 ', + 'FLNT_d7 ', 'FLNT_d8 ', 'FLNT_d9 ', 'FLNT_d10 ', 'FLNTC ', 'FLNTC_d1 ', + 'FLNTC_d2 ', 'FLNTC_d3 ', 'FLNTC_d4 ', 'FLNTC_d5 ', 'FLNTC_d6 ', 'FLNTC_d7 ', + 'FLNTC_d8 ', 'FLNTC_d9 ', 'FLNTC_d10 ', 'FLNTCLR ', 'FLNTCLR_d1 ', 'FLNTCLR_d2 ', + 'FLNTCLR_d3 ', 'FLNTCLR_d4 ', 'FLNTCLR_d5 ', 'FLNTCLR_d6 ', 'FLNTCLR_d7 ', 'FLNTCLR_d8 ', + 'FLNTCLR_d9 ', 'FLNTCLR_d10', 'FREQCLR ', 'FREQCLR_d1 ', 'FREQCLR_d2 ', 'FREQCLR_d3 ', + 'FREQCLR_d4 ', 'FREQCLR_d5 ', 'FREQCLR_d6 ', 'FREQCLR_d7 ', 'FREQCLR_d8 ', 'FREQCLR_d9 ', + 'FREQCLR_d10', 'FLUT ', 'FLUT_d1 ', 'FLUT_d2 ', 'FLUT_d3 ', 'FLUT_d4 ', + 'FLUT_d5 ', 'FLUT_d6 ', 'FLUT_d7 ', 'FLUT_d8 ', 'FLUT_d9 ', 'FLUT_d10 ', + 'FLUTC ', 'FLUTC_d1 ', 'FLUTC_d2 ', 'FLUTC_d3 ', 'FLUTC_d4 ', 'FLUTC_d5 ', + 'FLUTC_d6 ', 'FLUTC_d7 ', 'FLUTC_d8 ', 'FLUTC_d9 ', 'FLUTC_d10 ', 'LWCF ', + 'LWCF_d1 ', 'LWCF_d2 ', 'LWCF_d3 ', 'LWCF_d4 ', 'LWCF_d5 ', 'LWCF_d6 ', + 'LWCF_d7 ', 'LWCF_d8 ', 'LWCF_d9 ', 'LWCF_d10 ', 'FLNS ', 'FLNS_d1 ', + 'FLNS_d2 ', 'FLNS_d3 ', 'FLNS_d4 ', 'FLNS_d5 ', 'FLNS_d6 ', 'FLNS_d7 ', + 'FLNS_d8 ', 'FLNS_d9 ', 'FLNS_d10 ', 'FLNSC ', 'FLNSC_d1 ', 'FLNSC_d2 ', + 'FLNSC_d3 ', 'FLNSC_d4 ', 'FLNSC_d5 ', 'FLNSC_d6 ', 'FLNSC_d7 ', 'FLNSC_d8 ', + 'FLNSC_d9 ', 'FLNSC_d10 ', 'FLDS ', 'FLDS_d1 ', 'FLDS_d2 ', 'FLDS_d3 ', + 'FLDS_d4 ', 'FLDS_d5 ', 'FLDS_d6 ', 'FLDS_d7 ', 'FLDS_d8 ', 'FLDS_d9 ', + 'FLDS_d10 ', 'AODDUST1 ', 'AODDUST3 ', 'AODDUST ', 'AODVIS ', 'CCN3 ' + hist_max_frames = 1 + hist_output_frequency = '1*monthly' + hist_precision = 'REAL32' + hist_file_type = 'history' +/ + +&hist_file_config_nl + hist_volume = 'h3' + hist_inst_fields = 'T', 'U', 'V' + hist_max_frames = 24 + hist_output_frequency = '2*nsteps' + hist_precision = 'REAL64' + hist_file_type = 'history' +/ diff --git a/test/unit/sample_files/hist_config_files/rad_config b/test/unit/sample_files/hist_config_files/rad_config new file mode 100644 index 00000000..b9fd6b6d --- /dev/null +++ b/test/unit/sample_files/hist_config_files/rad_config @@ -0,0 +1,47 @@ +hist_add_avg_fields;h0: SOLIN, SOLIN_d1, SOLIN_d2, SOLIN_d3, SOLIN_d4, SOLIN_d5 +hist_add_avg_fields: SOLIN_d6, SOLIN_d7, SOLIN_d8, SOLIN_d9, SOLIN_d10 +hist_add_avg_fields: QRS, QRS_d1, QRS_d2, QRS_d3, QRS_d4, QRS_d5 +hist_add_avg_fields: QRS_d6, QRS_d7, QRS_d8, QRS_d9, QRS_d10 +hist_add_avg_fields: FSNT, FSNT_d1, FSNT_d2, FSNT_d3, FSNT_d4, FSNT_d5 +hist_add_avg_fields: FSNT_d6, FSNT_d7, FSNT_d8, FSNT_d9, FSNT_d10 +hist_add_avg_fields: FSNTC, FSNTC_d1, FSNTC_d2, FSNTC_d3, FSNTC_d4, FSNTC_d5 +hist_add_avg_fields: FSNTC_d6, FSNTC_d7, FSNTC_d8, FSNTC_d9, FSNTC_d10 +hist_add_avg_fields: FSNTOA, FSNTOA_d1, FSNTOA_d2, FSNTOA_d3, FSNTOA_d4 +hist_add_avg_fields: FSNTOA_d5, FSNTOA_d6, FSNTOA_d7, FSNTOA_d8, FSNTOA_d9 +hist_add_avg_fields: FSNTOA_d10, FSNTOAC, FSNTOAC_d1, FSNTOAC_d2, FSNTOAC_d3 +hist_add_avg_fields: FSNTOAC_d4, FSNTOAC_d5 +hist_add_avg_fields: FSNTOAC_d6, FSNTOAC_d7, FSNTOAC_d8, FSNTOAC_d9, FSNTOAC_d10 +hist_add_avg_fields: SWCF, SWCF_d1, SWCF_d2, SWCF_d3, SWCF_d4, SWCF_d5 +hist_add_avg_fields: SWCF_d6, SWCF_d7, SWCF_d8, SWCF_d9, SWCF_d10 +hist_add_avg_fields: FSNS, FSNS_d1, FSNS_d2, FSNS_d3, FSNS_d4, FSNS_d5 +hist_add_avg_fields: FSNS_d6, FSNS_d7, FSNS_d8, FSNS_d9, FSNS_d10 +hist_add_avg_fields: FSNSC, FSNSC_d1, FSNSC_d2, FSNSC_d3, FSNSC_d4, FSNSC_d5 +hist_add_avg_fields: FSNSC_d6, FSNSC_d7, FSNSC_d8, FSNSC_d9, FSNSC_d10 +hist_add_avg_fields: FSUTOA, FSUTOA_d1, FSUTOA_d2, FSUTOA_d3, FSUTOA_d4, FSUTOA_d5 +hist_add_avg_fields: FSUTOA_d6, FSUTOA_d7, FSUTOA_d8, FSUTOA_d9, FSUTOA_d10 +hist_add_avg_fields: FSDSC, FSDSC_d1, FSDSC_d2, FSDSC_d3, FSDSC_d4, FSDSC_d5 +hist_add_avg_fields: FSDSC_d6, FSDSC_d7, FSDSC_d8, FSDSC_d9, FSDSC_d10 +hist_add_avg_fields: FSDS, FSDS_d1, FSDS_d2, FSDS_d3, FSDS_d4, FSDS_d5 +hist_add_avg_fields: FSDS_d6, FSDS_d7, FSDS_d8, FSDS_d9, FSDS_d10 +hist_add_avg_fields: QRL, QRL_d1, QRL_d2, QRL_d3, QRL_d4, QRL_d5 +hist_add_avg_fields: QRL_d6, QRL_d7, QRL_d8, QRL_d9, QRL_d10 +hist_add_avg_fields: FLNT, FLNT_d1, FLNT_d2, FLNT_d3, FLNT_d4, FLNT_d5 +hist_add_avg_fields: FLNT_d6, FLNT_d7, FLNT_d8, FLNT_d9, FLNT_d10 +hist_add_avg_fields: FLNTC, FLNTC_d1, FLNTC_d2, FLNTC_d3, FLNTC_d4, FLNTC_d5 +hist_add_avg_fields: FLNTC_d6, FLNTC_d7, FLNTC_d8, FLNTC_d9, FLNTC_d10 +hist_add_avg_fields: FLNTCLR, FLNTCLR_d1, FLNTCLR_d2, FLNTCLR_d3, FLNTCLR_d4, FLNTCLR_d5 +hist_add_avg_fields: FLNTCLR_d6, FLNTCLR_d7, FLNTCLR_d8, FLNTCLR_d9, FLNTCLR_d10 +hist_add_avg_fields: FREQCLR, FREQCLR_d1, FREQCLR_d2, FREQCLR_d3, FREQCLR_d4, FREQCLR_d5 +hist_add_avg_fields: FREQCLR_d6, FREQCLR_d7, FREQCLR_d8, FREQCLR_d9, FREQCLR_d10 +hist_add_avg_fields: FLUT, FLUT_d1, FLUT_d2, FLUT_d3, FLUT_d4, FLUT_d5 +hist_add_avg_fields: FLUT_d6, FLUT_d7, FLUT_d8, FLUT_d9, FLUT_d10 +hist_add_avg_fields: FLUTC, FLUTC_d1, FLUTC_d2, FLUTC_d3, FLUTC_d4, FLUTC_d5 +hist_add_avg_fields: FLUTC_d6, FLUTC_d7, FLUTC_d8, FLUTC_d9, FLUTC_d10 +hist_add_avg_fields: LWCF, LWCF_d1, LWCF_d2, LWCF_d3, LWCF_d4, LWCF_d5 +hist_add_avg_fields: LWCF_d6, LWCF_d7, LWCF_d8, LWCF_d9, LWCF_d10 +hist_add_avg_fields: FLNS, FLNS_d1, FLNS_d2, FLNS_d3, FLNS_d4, FLNS_d5 +hist_add_avg_fields: FLNS_d6, FLNS_d7, FLNS_d8, FLNS_d9, FLNS_d10 +hist_add_avg_fields: FLNSC, FLNSC_d1, FLNSC_d2, FLNSC_d3, FLNSC_d4, FLNSC_d5 +hist_add_avg_fields: FLNSC_d6, FLNSC_d7, FLNSC_d8, FLNSC_d9, FLNSC_d10 +hist_add_avg_fields: FLDS, FLDS_d1, FLDS_d2, FLDS_d3, FLDS_d4, FLDS_d5 +hist_add_avg_fields: FLDS_d6, FLDS_d7, FLDS_d8, FLDS_d9, FLDS_d10 diff --git a/test/unit/sample_files/hist_config_files/user_nl_cam_flat b/test/unit/sample_files/hist_config_files/user_nl_cam_flat new file mode 100644 index 00000000..0116732a --- /dev/null +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_flat @@ -0,0 +1,18 @@ +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value + +! History configuration +hist_add_avg_fields;h1: MOE, LARRY, CURLY +hist_add_max_fields;h1: Skirt, Mad +hist_add_min_fields;h1: mouse, bin, gin +hist_add_var_fields;h1: std, stp +hist_output_frequency;h1: 14*hours + +ncdata = 'atm/cam/inic/se/ape_topo_cam4_ne16np4_L32_c171020.nc' +use_topo_file = .false. + +! More history configuration +hist_add_inst_fields;h3: T, U, V +hist_output_frequency;h3: 2*nsteps +hist_precision;h3: REAL64 +hist_max_frames;h3: 24 diff --git a/test/unit/sample_files/hist_config_files/user_nl_cam_multi b/test/unit/sample_files/hist_config_files/user_nl_cam_multi new file mode 100644 index 00000000..8e9feec3 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_multi @@ -0,0 +1,17 @@ +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value + +ncdata = 'atm/cam/inic/se/ape_topo_cam4_ne16np4_L32_c171020.nc' +use_topo_file = .false. + +! History configuration +hist_no_defaults: True +hist_diag_file;h0: amwg_hist_config +hist_remove_fields;h0: TAUTMSX, TAUTMSY +hist_output_frequency;h0: monthly +hist_precision;h0: REAL32 + +hist_add_inst_fields;h3: T, U, V +hist_output_frequency;h3: 2*nsteps +hist_precision;h3: REAL64 +hist_max_frames;h3: 24 diff --git a/test/unit/test_hist_config.py b/test/unit/test_hist_config.py new file mode 100644 index 00000000..2ca30dfc --- /dev/null +++ b/test/unit/test_hist_config.py @@ -0,0 +1,171 @@ +#! /usr/bin/env python3 +#----------------------------------------------------------------------- +# Description: Contains unit tests for testing CAM history configuration +# parsing and namelist generation +# +# Assumptions: +# +# Command line arguments: none +# +# Usage: python3 test_registry.py # run the unit tests +#----------------------------------------------------------------------- + +"""Test parse_hist_config_file in hist_config.py""" + +import glob +import filecmp +import logging +import os +import shutil +import sys +import unittest +import xml.etree.ElementTree as ET + +__TEST_DIR = os.path.dirname(os.path.abspath(__file__)) +_CAM_ROOT = os.path.abspath(os.path.join(__TEST_DIR, os.pardir, os.pardir)) +__CIME_CONFIG_DIR = os.path.join(_CAM_ROOT, "cime_config") +_SAMPLE_FILES_DIR = os.path.join(__TEST_DIR, + "sample_files", "hist_config_files") +_TMP_DIR = os.path.join(__TEST_DIR, "tmp") +_LOGGER = logging.getLogger(__name__) + +# Find python version +PY3 = sys.version_info[0] > 2 +if PY3: + __FILE_OPEN = (lambda x: open(x, 'r', encoding='utf-8')) +else: + __FILE_OPEN = (lambda x: open(x, 'r')) +# End if + +if not os.path.exists(__CIME_CONFIG_DIR): + raise ImportError("Cannot find /cime_config") + +if not os.path.exists(_SAMPLE_FILES_DIR): + raise ImportError("Cannot find sample files directory") + +sys.path.append(__CIME_CONFIG_DIR) + +# pylint: disable=wrong-import-position +from hist_config import HistoryConfig +# pylint: enable=wrong-import-position + +############################################################################### +def remove_files(file_list): +############################################################################### + """Remove files in if they exist""" + for fpath in file_list: + if os.path.exists(fpath): + os.remove(fpath) + # End if + # End for + +class HistConfigTest(unittest.TestCase): + + """Tests for `parse_hist_config_file`.""" + + @classmethod + def setUpClass(cls): + """Clean output directory (tmp) before running tests""" + if not os.path.exists(_TMP_DIR): + os.makedirs(_TMP_DIR) + + remove_files(glob.iglob(os.path.join(_TMP_DIR, '*.*'))) + super(cls, HistConfigTest).setUpClass() + + def _test_config(self, config, vol, prec, maxf, outfreq, ftype): + """Check the properties of against the other inputs: + : volume + : precision + : max_frames + : output_frequency + : file_type""" + self.assertEqual(config.volume, vol, msg="Bad volume") + self.assertEqual(config.precision, prec, msg="Bad precision") + self.assertEqual(config.max_frames, maxf, msg="Bad max frames") + self.assertEqual(config.output_frequency, outfreq, + msg="Bad output frequency") + self.assertEqual(config.file_type, ftype, msg="Bad file type") + + def test_flat_user_nl_cam(self): + """Test history entries that would be appropriate in user_nl_cam. + Check that the correct Fortran namelist is generated""" + # Setup test + in_source = os.path.join(_SAMPLE_FILES_DIR, "user_nl_cam_flat") + out_source = os.path.join(_TMP_DIR, "atm_in") + out_test = os.path.join(_SAMPLE_FILES_DIR, "atm_in_flat") + remove_files([out_source]) + # Run test + _LOGGER.setLevel(logging.DEBUG) + hist_configs = HistoryConfig(filename=in_source, logger=_LOGGER) + # Check that HistoryConfig object was created + amsg = "Test failure: no HistConfig object created" + self.assertTrue(isinstance(hist_configs, HistoryConfig), msg=amsg) + clen = len(hist_configs) + amsg = "Test failure: Found {} history files, expected 2".format(clen) + self.assertEqual(clen, 2, msg=amsg) + # Check properties of created config objects + self.assertTrue('h1' in hist_configs, msg="'h1' not in hist_configs") + hconfig = hist_configs['h1'] + self._test_config(hconfig, 'h1', 'REAL32', 30, (14, 'hours'), 'history') + self.assertTrue('h3' in hist_configs, msg="'h3' not in hist_configs") + hconfig = hist_configs['h3'] + self._test_config(hconfig, 'h3', 'REAL64', 24, (2, 'nsteps'), 'history') + # Write out the namelist file + with open(out_source, 'w', encoding='utf-8') as nl_file: + hist_configs.output_class_namelist(nl_file) + for key in sorted(hist_configs.keys()): + hist_configs[key].output_config_namelist(nl_file) + # end for + # end with + # Make sure each output file was created + amsg = "{} does not exist".format(out_source) + self.assertTrue(os.path.exists(out_source), msg=amsg) + # Make sure the output file is correct + amsg = "{} does not match {}".format(out_test, out_source) + self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), + msg=amsg) + + def test_multi_user_nl_cam(self): + """Test history entries that would be appropriate in user_nl_cam that + includes other history configuration files. + Check that the correct Fortran namelist is generated""" + # Setup test + in_source = os.path.join(_SAMPLE_FILES_DIR, "user_nl_cam_multi") + out_source = os.path.join(_TMP_DIR, "atm_in_multi") + out_test = os.path.join(_SAMPLE_FILES_DIR, "atm_in_multi") + remove_files([out_source]) + # Run test + hist_configs = HistoryConfig(filename=in_source, logger=_LOGGER) + _LOGGER.setLevel(logging.DEBUG) + # Check return code + amsg = "Test failure: no HistConfig object created" + self.assertTrue(isinstance(hist_configs, HistoryConfig), msg=amsg) + clen = len(hist_configs) + amsg = "Test failure: Found {} history files, expected 2".format(clen) + self.assertEqual(clen, 2, msg=amsg) + # Check properties of created config objects + self.assertTrue('h0' in hist_configs, msg="'h0' not in hist_configs") + hconfig = hist_configs['h0'] + self._test_config(hconfig, 'h0', 'REAL32', 1, (1, 'monthly'), 'history') + self.assertTrue('h3' in hist_configs, msg="'h3' not in hist_configs") + hconfig = hist_configs['h3'] + self._test_config(hconfig, 'h3', 'REAL64', 24, (2, 'nsteps'), 'history') + # Write out the namelist file + with open(out_source, 'w', encoding='utf-8') as nl_file: + hist_configs.output_class_namelist(nl_file) + for key in sorted(hist_configs.keys()): + hist_configs[key].output_config_namelist(nl_file) + # end for + # end with + # Make sure each output file was created + amsg = "{} does not exist".format(out_source) + self.assertTrue(os.path.exists(out_source), msg=amsg) + # Make sure the output file is correct + amsg = "{} does not match {}".format(out_test, out_source) + self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), + msg=amsg) + +############################################################################## + +if __name__ == '__main__': + unittest.main() diff --git a/test/utils_tests/CMakeLists.txt b/test/utils_tests/CMakeLists.txt new file mode 100644 index 00000000..367e1497 --- /dev/null +++ b/test/utils_tests/CMakeLists.txt @@ -0,0 +1,127 @@ +CMAKE_MINIMUM_REQUIRED(VERSION 3.11) +PROJECT(TestUtils) +ENABLE_LANGUAGE(Fortran) + +include(CMakeForceCompiler) + +find_package(MPI REQUIRED) +add_definitions(${MPI_Fortran_COMPILE_FLAGS}) +include_directories(${MPI_Fortran_INCLUDE_PATH}) +link_directories(${MPI_Fortran_LIBRARIES}) + +#----------------------------------------------------------------------------- +# +# Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) +# +#----------------------------------------------------------------------------- +GET_FILENAME_COMPONENT(TEST_PATH ${CMAKE_CURRENT_SOURCE_DIR} DIRECTORY) +SET(UTILS_PATH ${TEST_PATH}/include) +GET_FILENAME_COMPONENT(ROOT_PATH ${TEST_PATH} DIRECTORY) +SET(SRC_PATH ${ROOT_PATH}/src) +SET(HIST_PATH ${SRC_PATH}/history) +# Find CIME directory +if (EXISTS "${ROOT_PATH}/cime") + SET(CIME_PATH ${ROOT_PATH}/cime) +else(EXISTS "${ROOT_PATH}/cime") + GET_FILENAME_COMPONENT(_components ${ROOT_PATH} DIRECTORY) + GET_FILENAME_COMPONENT(_toplev ${_components} DIRECTORY) + SET(CIME_PATH ${_toplev}/cime) +endif(EXISTS "${ROOT_PATH}/cime") +# Test copies of CAM and CIME utility files +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_string_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_infnan_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_assert_mod.F90") +# Regular CAM and CIME utility files +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_kind_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_mpi_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_abort_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_sys_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_timer_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_log_mod.F90") +LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_strconvert_mod.F90") +LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") +# Utility test modules +LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/string_utils_tests.F90") +# TEST_EXE.F90 is the name of the program source file +SET(TEST_EXE "test_utils") +ADD_EXECUTABLE(${TEST_EXE} ${TEST_EXE}.F90) + +#----------------------------------------------------------------------------- +############################################################################## +# +# End of project-specific input +# +############################################################################## +#----------------------------------------------------------------------------- + +# Use rpaths on MacOSX +set(CMAKE_MACOSX_RPATH 1) + +#----------------------------------------------------------------------------- +# Set a default build type if none was specified +if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + #message(STATUS "Setting build type to 'Debug' as none was specified.") + #set(CMAKE_BUILD_TYPE Debug CACHE STRING "Choose the type of build." FORCE) + message(STATUS "Setting build type to 'Release' as none was specified.") + set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) + + # Set the possible values of build type for cmake-gui + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" + "MinSizeRel" "RelWithDebInfo") +endif() + +ADD_COMPILE_OPTIONS(-O0) + +if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") +# gfortran +# MESSAGE("gfortran being used.") + ADD_COMPILE_OPTIONS(-fcheck=all) + ADD_COMPILE_OPTIONS(-fbacktrace) + ADD_COMPILE_OPTIONS(-ffpe-trap=zero) + ADD_COMPILE_OPTIONS(-finit-real=nan) + ADD_COMPILE_OPTIONS(-ggdb) + ADD_COMPILE_OPTIONS(-ffree-line-length-none) + ADD_COMPILE_OPTIONS(-cpp) + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DHAVE_IEEE_ARITHMETIC") +elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") +# ifort +# MESSAGE("ifort being used.") + #ADD_COMPILE_OPTIONS(-check all) + ADD_COMPILE_OPTIONS(-fpe0) + ADD_COMPILE_OPTIONS(-warn) + ADD_COMPILE_OPTIONS(-traceback) + ADD_COMPILE_OPTIONS(-debug extended) + ADD_COMPILE_OPTIONS(-fpp) +elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") +# pgf90 +# MESSAGE("pgf90 being used.") + ADD_COMPILE_OPTIONS(-g) + ADD_COMPILE_OPTIONS(-Mipa=noconst) + ADD_COMPILE_OPTIONS(-traceback) + ADD_COMPILE_OPTIONS(-Mfree) + ADD_COMPILE_OPTIONS(-Mfptrap) + ADD_COMPILE_OPTIONS(-Mpreprocess) +else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") + message (FATAL_ERROR "This program has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${CMAKE_SOURCE_DIR}/CMakeLists.txt") +endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") +set (CMAKE_Fortran_FLAGS + "${CMAKE_Fortran_FLAGS} -I${CIME_PATH}/src/share/include") + +#----------------------------------------------------------------------------- +# Set OpenMP flags for C/C++/Fortran +if (OPENMP) + include(detect_openmp) + detect_openmp() + set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ${OpenMP_C_FLAGS}") + set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${OpenMP_CXX_FLAGS}") + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") + message(STATUS "Enable OpenMP support for C/C++/Fortran compiler") +else(OPENMP) + message (STATUS "Disable OpenMP support for C/C++/Fortran compiler") +endif() +TARGET_SOURCES(${TEST_EXE} PUBLIC ${SOURCE_FILES}) +TARGET_LINK_LIBRARIES(${TEST_EXE} ${MPI_Fortran_LIBRARIES}) + +set_target_properties(${TEST_EXE} PROPERTIES + COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" + LINK_FLAGS "${CMAKE_Fortran_FLAGS}") diff --git a/test/utils_tests/string_utils_tests.F90 b/test/utils_tests/string_utils_tests.F90 new file mode 100644 index 00000000..86cf0858 --- /dev/null +++ b/test/utils_tests/string_utils_tests.F90 @@ -0,0 +1,88 @@ +module string_utils_tests + + use shr_kind_mod, only: max_chars=>SHR_KIND_CX + use shr_kind_mod, only: max_flen=>SHR_KIND_CL + use shr_kind_mod, only: cs=>SHR_KIND_CS + + implicit none + private + + public test_string_utils + +CONTAINS + + subroutine test_string_utils(errcnt, testcnt) + use string_utils, only: parse_multiplier + ! Dummy arguments + integer, intent(out) :: errcnt + integer, intent(out) :: testcnt + ! Local variables + integer :: multiplier + character(len=cs) :: token + character(len=max_flen) :: errmsg + character(len=*), parameter :: subname = 'test_string_utils: ' + + errcnt = 0 + testcnt = 0 + ! Test normal case + call parse_multiplier("9*nstep", multiplier, token, errmsg=errmsg) + testcnt = testcnt + 1 + if ((multiplier /= 9) .or. (trim(token) /= "nstep")) then + write(6, *) subname, trim(errmsg) + errcnt = errcnt + 1 + end if + ! Test default count + call parse_multiplier("nstep", multiplier, token, errmsg=errmsg) + testcnt = testcnt + 1 + if ((multiplier /= 1) .or. (trim(token) /= "nstep")) then + write(6, *) subname, trim(errmsg) + errcnt = errcnt + 1 + end if + ! Test bad multiplier + call parse_multiplier("9a*nstep", multiplier, token, errmsg=errmsg) + testcnt = testcnt + 1 + if ((multiplier /= -1) .or. (len_trim(token) > 0)) then + if (multiplier /= -1) then + write(6, '(2a,i0,a)') subname, "multiplier = ", multiplier, & + ", should be -1" + end if + if (len_trim(token) > 0) then + write(6, *) subname, "token = '", trim(token), "', should be empty" + end if + errcnt = errcnt + 1 + else if (adjustl(trim(errmsg)) /= & + "Invalid multiplier, '9a' in '9a*nstep'") then + write(6, *) subname, "!", trim(errmsg), "!" + errcnt = errcnt + 1 + end if + ! Test empty string + call parse_multiplier("", multiplier, token, errmsg=errmsg) + testcnt = testcnt + 1 + if ((multiplier /= 0) .or. (trim(token) /= "")) then + write(6, *) subname, trim(errmsg) + errcnt = errcnt + 1 + end if + ! Test member of allowed set + call parse_multiplier("9*nstep", multiplier, token, errmsg=errmsg, & + allowed_set = (/ 'nhour ', 'nhours', 'nstep ', 'nsteps' /)) + testcnt = testcnt + 1 + if ((multiplier /= 9) .or. (trim(token) /= "nstep")) then + write(6, *) subname, trim(errmsg) + errcnt = errcnt + 1 + end if + ! Test not member of allowed set + call parse_multiplier("9*step", multiplier, token, errmsg=errmsg, & + allowed_set = (/ 'nhour ', 'nstep ', 'nsteps' /)) + testcnt = testcnt + 1 + if ((multiplier /= -1) .or. (trim(token) /= "")) then + write(6, *) subname, trim(errmsg) + errcnt = errcnt + 1 + else if (adjustl(trim(errmsg)) /= & + "Error, token, 'step' not in (/ 'nhour', 'nstep', 'nsteps' /)") then + write(6, *) subname, "!", trim(errmsg), "!" + errcnt = errcnt + 1 + end if + + end subroutine test_string_utils + +end module string_utils_tests diff --git a/test/utils_tests/test_utils.F90 b/test/utils_tests/test_utils.F90 new file mode 100644 index 00000000..51a8a8f0 --- /dev/null +++ b/test/utils_tests/test_utils.F90 @@ -0,0 +1,30 @@ +program test_utils + + + use shr_kind_mod, only: max_chars=>SHR_KIND_CX + use shr_kind_mod, only: max_flen=>SHR_KIND_CL + use string_utils_tests, only: test_string_utils + + implicit none + + integer :: out_unit = 6 + integer :: ierr + integer :: errcnt + integer :: testcnt + integer :: total_errcnt = 0 + integer :: total_tests = 0 + + ! Test string utilities + call test_string_utils(errcnt, testcnt) + total_errcnt = total_errcnt + errcnt + total_tests = total_tests + testcnt + + if (total_errcnt > 0) then + write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' + STOP 1 + else + write(6, '(a,i0,a)') "All ", total_tests, " utility tests passed!" + STOP 0 + end if + +end program test_utils From 44f166064849b5240f94ff035cb7c4d140953069 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Mon, 1 Aug 2022 20:43:16 -0600 Subject: [PATCH 02/79] Correct CIME paths for new CIME --- cime_config/create_readnl_files.py | 7 +-- src/history/cam_history.F90 | 87 +---------------------------- src/history/cam_history_support.F90 | 28 +--------- 3 files changed, 7 insertions(+), 115 deletions(-) diff --git a/cime_config/create_readnl_files.py b/cime_config/create_readnl_files.py index 6e367fe6..2696ed83 100644 --- a/cime_config/create_readnl_files.py +++ b/cime_config/create_readnl_files.py @@ -23,10 +23,9 @@ _CURRDIR = os.path.abspath(os.path.dirname(__file__)) _CAMROOT = os.path.abspath(os.path.join(_CURRDIR, os.pardir)) _SPINSCRIPTS = os.path.join(_CAMROOT, "ccpp_framework", 'scripts') -_XML_SCHEMAS = os.path.join(_CAMROOT, "cime", "CIME", "data", "config", - "xml_schemas") -_PG_SCHEMAS = os.path.join(_CAMROOT, "cime", "CIME", "ParamGen", - "xml_schema") +_XML_SCHEMAS = os.path.join(_CAMROOT, "cime", "config", "xml_schemas") +_PG_SCHEMAS = os.path.join(_CAMROOT, "cime", "scripts", "lib", "CIME", + "ParamGen", "xml_schema") if _SPINSCRIPTS not in sys.path: sys.path.append(_SPINSCRIPTS) # end if diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index e7a367b7..a0b47a1c 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -65,26 +65,6 @@ module cam_history private save - ! history file info - type (active_entry), pointer :: file(:) => null() ! history file - type (active_entry), target, allocatable :: history_file(:) ! history files - ! restarthistory_files is a set of files containing partially accumulated - ! history fields (e.g., an averaged field saved at mid month). - type (active_entry), target, allocatable :: restarthistory_files(:) - ! - - integer :: nfmaster = 0 ! number of fields in master field list - integer :: nflds(pfiles) ! number of fields per file - - real(r8) :: beg_time(pfiles) ! time at beginning of an averaging interval - - ! regen_hist_file is .true. for files that require a regeneration volume - logical :: regen_hist_file(pfiles) = .false. - logical :: write_file(pfiles) = .false. ! .true. to write file - ! empty_hfiles: Namelist flag indicates no default history fields - logical :: empty_hfiles = .false. - logical :: hfiles_defined = .false. ! flag indicates history contents have been defined - character(len=cl) :: model_doi_url = '' ! Model DOI character(len=cl) :: caseid = '' ! case ID character(len=cl) :: ctitle = '' ! case title @@ -92,9 +72,8 @@ module cam_history character(len=*), parameter :: history_namelist = 'cam_history_nl' ! hrestpath: Full history restart pathnames character(len=max_string_len) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) - character(len=max_string_len) :: cpath(pfiles) ! Array of current pathnames - character(len=max_string_len) :: nhfil(pfiles) ! Array of current file names - character(len=1) :: avgflag_perfile(pfiles) = (/(' ',idx=1,pfiles)/) ! per file averaging flag + character(len=max_string_len) :: cpath(pfiles) ! Array of current pathnames + character(len=max_string_len) :: nhfil(pfiles) ! Array of current file names character(len=16) :: logname ! user name character(len=16) :: host ! host name character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or @@ -103,19 +82,6 @@ module cam_history ! included on IC file ! .false. include only required fields ! .true. include required *and* optional fields - character(len=fieldname_lenp2) :: fincl(pflds,pfiles) ! List of fields to add to primary h-file - character(len=max_chars) :: fincllonlat(pflds,pfiles) ! List of fields to add to primary h-file - character(len=fieldname_lenp2) :: fexcl(pflds,pfiles) ! List of fields to rm from primary h-file - ! fout_prec: List of fields to change default history output prec - character(len=fieldname_lenp2) :: fout_prec(pflds, pfiles) - character(len=fieldname_suffix_len ) :: fieldname_suffix = '&IC' ! Suffix appended to field names for IC file - - ! Allowed history averaging flags - ! This should match namelist_definition.xml => avgflag_perfile (+ ' ') - ! The presence of 'ABI' and 'XML' in this string is a coincidence - character(len=7), parameter :: HIST_AVG_FLAGS = ' ABIXML' - character(len=22) ,parameter :: LT_DESC = 'mean (over local time)' ! local time description - logical :: collect_column_output(pfiles) integer :: maxvarmdims=1 ! @@ -128,11 +94,6 @@ module cam_history character(len=max_string_len) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) ! filename specifyer - interface addfld - module procedure addfld_1d - module procedure addfld_nd - end interface addfld - ! Needed by cam_diagnostics public :: inithist_all @@ -209,50 +170,6 @@ subroutine history_readnl(nlfile) interpolate_type(:) = 1 interpolate_output(:) = .false. - ! Initialize namelist 'temporary variables' - do f = 1, pflds - fincl1(fld_idx) = ' ' - fincl2(fld_idx) = ' ' - fincl3(fld_idx) = ' ' - fincl4(fld_idx) = ' ' - fincl5(fld_idx) = ' ' - fincl6(fld_idx) = ' ' - fincl7(fld_idx) = ' ' - fincl8(fld_idx) = ' ' - fincl9(fld_idx) = ' ' - fincl10(fld_idx) = ' ' - fincl1lonlat(fld_idx) = ' ' - fincl2lonlat(fld_idx) = ' ' - fincl3lonlat(fld_idx) = ' ' - fincl4lonlat(fld_idx) = ' ' - fincl5lonlat(fld_idx) = ' ' - fincl6lonlat(fld_idx) = ' ' - fincl7lonlat(fld_idx) = ' ' - fincl8lonlat(fld_idx) = ' ' - fincl9lonlat(fld_idx) = ' ' - fincl10lonlat(fld_idx) = ' ' - fexcl1(fld_idx) = ' ' - fexcl2(fld_idx) = ' ' - fexcl3(fld_idx) = ' ' - fexcl4(fld_idx) = ' ' - fexcl5(fld_idx) = ' ' - fexcl6(fld_idx) = ' ' - fexcl7(fld_idx) = ' ' - fexcl8(fld_idx) = ' ' - fexcl9(fld_idx) = ' ' - fexcl10(fld_idx) = ' ' - fwrtpr1(fld_idx) = ' ' - fwrtpr2(fld_idx) = ' ' - fwrtpr3(fld_idx) = ' ' - fwrtpr4(fld_idx) = ' ' - fwrtpr5(fld_idx) = ' ' - fwrtpr6(fld_idx) = ' ' - fwrtpr7(fld_idx) = ' ' - fwrtpr8(fld_idx) = ' ' - fwrtpr9(fld_idx) = ' ' - fwrtpr10(fld_idx) = ' ' - end do - if (trim(history_namelist) /= 'cam_history_nl') then call endrun('HISTORY_READNL: CAM history namelist mismatch') end if diff --git a/src/history/cam_history_support.F90 b/src/history/cam_history_support.F90 index 703fe2fb..1f779904 100644 --- a/src/history/cam_history_support.F90 +++ b/src/history/cam_history_support.F90 @@ -3,9 +3,7 @@ module cam_history_support !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! !! cam_history_support is used by cam_history as well as by the dycores - !! (for vertical coordinate and "mdim" support). Some parameters are - !! also referenced by cam_grid_support (although those could be copied - !! if necessary). + !! (for vertical coordinate support). !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -53,31 +51,9 @@ module cam_history_support procedure :: deallocate => history_patch_deallocate end type history_patch_t - ! - ! dim_index_2d, dim_index_3d: 2-D & 3-D dimension index lower & upper bounds - ! - type, public :: dim_index_2d ! 2-D dimension index - integer :: beg1, end1 ! lower & upper bounds of 1st dimension - integer :: beg2, end2 ! lower & upper bounds of 2nd dimension - contains - procedure :: dim_sizes_2d => dim_index_2d_dim_sizes_2d - procedure :: dim_sizes_arr => dim_index_2d_dim_size_arr - generic :: dim_sizes => dim_sizes_arr, dim_sizes_2d - end type dim_index_2d - - type, public :: dim_index_3d ! 3-D dimension index - integer :: beg1, end1 ! lower & upper bounds of 1st dimension - integer :: beg2, end2 ! lower & upper bounds of 2nd dimension - integer :: beg3, end3 ! lower & upper bounds of 3rd dimension - contains - procedure :: dim_sizes_3d => dim_index_3d_dim_sizes_3d - procedure :: dim_sizes_arr => dim_index_3d_dim_size_arr - generic :: dim_sizes => dim_sizes_arr, dim_sizes_3d - end type dim_index_3d - !--------------------------------------------------------------------------- ! - ! field_info: A derived type containing information in an addfld call. + ! field_info: A derived type containing information in a history field ! !--------------------------------------------------------------------------- type, public :: field_info From ff48e4fbad89634c9ec82671e7be2953c546fb63 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Mon, 1 Aug 2022 22:54:08 -0600 Subject: [PATCH 03/79] Start stripping out old stuff --- src/history/cam_history.F90 | 123 ++---------------------------------- 1 file changed, 6 insertions(+), 117 deletions(-) diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index a0b47a1c..8fe8b23f 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -119,14 +119,11 @@ module cam_history CONTAINS subroutine history_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: masterproc, masterprocid, mpicom - use spmd_utils, only: mpi_integer, mpi_logical, mpi_character - use shr_string_mod, only: shr_string_toUpper - use time_manager, only: get_step_size - use sat_hist, only: sat_hist_readnl + use spmd_utils, only: masterproc, masterprocid, mpicom + use spmd_utils, only: mpi_integer, mpi_logical, mpi_character + use cam_hist_config_file, only: hist_file_config_t + use cam_hist_config_file, only: hist_read_namelist_config + use time_manager, only: get_step_size ! Dummy argument character(len=*), intent(in) :: nlfile ! filepath of namelist input file @@ -134,116 +131,8 @@ subroutine history_readnl(nlfile) ! ! Local variables integer :: dtime ! Step time in seconds - integer :: unitn, ierr, f, t + integer :: unitn, ierr character(len=8) :: ctemp ! Temporary character string - - ! History namelist items - namelist /cam_history_nl/ & - diag_file1, diag_file2, diag_file3, diag_file4, diag_file5, & - diag_file6, diag_file7, diag_file8, diag_file9, diag_file10, & - lcltod_start, lcltod_stop, & - inithist, inithist_all, & - hfilename_spec, & - interpolate_nlat, interpolate_nlon, & - interpolate_gridtype, interpolate_type, interpolate_output - - ! Set namelist defaults (these should match initial values if given) - fincl(:,:) = ' ' - fincllonlat(:,:) = ' ' - fexcl(:,:) = ' ' - fout_prec(:,:) = ' ' - collect_column_output(:) = .false. - avgflag_perfile(:) = ' ' - ndens = 2 - hist_freq(1) = 0 - hist_freq(2:) = -24 - mfilt = 30 - inithist = 'YEARLY' - inithist_all = .false. - empty_hfiles = .false. - lcltod_start(:) = 0 - lcltod_stop(:) = 0 - hfilename_spec(:) = ' ' - interpolate_nlat(:) = 0 - interpolate_nlon(:) = 0 - interpolate_gridtype(:) = 1 - interpolate_type(:) = 1 - interpolate_output(:) = .false. - - if (trim(history_namelist) /= 'cam_history_nl') then - call endrun('HISTORY_READNL: CAM history namelist mismatch') - end if - if (masterproc) then - write(iulog, *) 'Read in ',history_namelist,' namelist from: ',trim(nlfile) - unitn = getunit() - open(unitn, file=trim(nlfile), status='old') - call find_group_name(unitn, history_namelist, status=ierr) - if (ierr == 0) then - read(unitn, cam_history_nl, iostat=ierr) - if (ierr /= 0) then - call endrun('history_readnl: ERROR reading namelist, '//trim(history_namelist)) - end if - end if - close(unitn) - call freeunit(unitn) - - do f = 1, pflds - fincl(f, 1) = fincl1(fld_idx) - fincl(f, 2) = fincl2(fld_idx) - fincl(f, 3) = fincl3(fld_idx) - fincl(f, 4) = fincl4(fld_idx) - fincl(f, 5) = fincl5(fld_idx) - fincl(f, 6) = fincl6(fld_idx) - fincl(f, 7) = fincl7(fld_idx) - fincl(f, 8) = fincl8(fld_idx) - fincl(f, 9) = fincl9(fld_idx) - fincl(f,10) = fincl10(fld_idx) - - fincllonlat(f, 1) = fincl1lonlat(fld_idx) - fincllonlat(f, 2) = fincl2lonlat(fld_idx) - fincllonlat(f, 3) = fincl3lonlat(fld_idx) - fincllonlat(f, 4) = fincl4lonlat(fld_idx) - fincllonlat(f, 5) = fincl5lonlat(fld_idx) - fincllonlat(f, 6) = fincl6lonlat(fld_idx) - fincllonlat(f, 7) = fincl7lonlat(fld_idx) - fincllonlat(f, 8) = fincl8lonlat(fld_idx) - fincllonlat(f, 9) = fincl9lonlat(fld_idx) - fincllonlat(f,10) = fincl10lonlat(fld_idx) - - fexcl(f, 1) = fexcl1(fld_idx) - fexcl(f, 2) = fexcl2(fld_idx) - fexcl(f, 3) = fexcl3(fld_idx) - fexcl(f, 4) = fexcl4(fld_idx) - fexcl(f, 5) = fexcl5(fld_idx) - fexcl(f, 6) = fexcl6(fld_idx) - fexcl(f, 7) = fexcl7(fld_idx) - fexcl(f, 8) = fexcl8(fld_idx) - fexcl(f, 9) = fexcl9(fld_idx) - fexcl(f,10) = fexcl10(fld_idx) - - fout_prec(f, 1) = fwrtpr1(fld_idx) - fout_prec(f, 2) = fwrtpr2(fld_idx) - fout_prec(f, 3) = fwrtpr3(fld_idx) - fout_prec(f, 4) = fwrtpr4(fld_idx) - fout_prec(f, 5) = fwrtpr5(fld_idx) - fout_prec(f, 6) = fwrtpr6(fld_idx) - fout_prec(f, 7) = fwrtpr7(fld_idx) - fout_prec(f, 8) = fwrtpr8(fld_idx) - fout_prec(f, 9) = fwrtpr9(fld_idx) - fout_prec(f,10) = fwrtpr10(fld_idx) - end do - - ! - ! If generate an initial conditions history file as an auxillary file: - ! - ctemp = shr_string_toUpper(inithist) - inithist = trim(ctemp) - if ( (inithist /= '6-HOURLY') .and. (inithist /= 'DAILY') .and. & - (inithist /= 'MONTHLY') .and. (inithist /= 'YEARLY') .and. & - (inithist /= 'CAMIOP') .and. (inithist /= 'ENDOFRUN')) then - inithist = 'NONE' - end if - ! ! History file write times ! Convert write freq. of hist files from hours to timesteps if necessary. ! From 56006e06e43cf4ed00342693316c1cd1a7d39016 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Sat, 6 Aug 2022 18:11:13 -0600 Subject: [PATCH 04/79] history test script and history unit test passing --- ...hist_config_file.F90 => cam_hist_file.F90} | 112 ++++++++------ src/history/cam_history.F90 | 129 +++++++--------- test/hist_tests/CMakeLists.txt | 5 +- test/hist_tests/run_test | 146 ++++++++++++++++++ test/hist_tests/test_history.F90 | 42 ++--- test/include/config.h | 0 test/include/pio.F90 | 12 ++ 7 files changed, 306 insertions(+), 140 deletions(-) rename src/history/{cam_hist_config_file.F90 => cam_hist_file.F90} (91%) create mode 100755 test/hist_tests/run_test create mode 100644 test/include/config.h create mode 100644 test/include/pio.F90 diff --git a/src/history/cam_hist_config_file.F90 b/src/history/cam_hist_file.F90 similarity index 91% rename from src/history/cam_hist_config_file.F90 rename to src/history/cam_hist_file.F90 index 66964a24..169ca925 100644 --- a/src/history/cam_hist_config_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1,14 +1,18 @@ -module cam_hist_config_file - ! Module to define and read CAM history configuration namelist entries. +module cam_hist_file + ! Module to define and read CAM history configuration namelist entries + ! and associated history files + ! Note: In test mode, endrun does not abort so there are a few lines + ! of special code to cleanly return after an endrun call. use ISO_FORTRAN_ENV, only: REAL64, REAL32 + use pio, only: file_desc_t use cam_history_support, only: max_fldlen=>max_fieldname_len use cam_interp_mod, only: interp_info_t=>hist_interp_info_t implicit none private - public :: hist_file_config_t + public :: hist_file_t public :: hist_read_namelist_config character(len=*), parameter :: hist_nl_group_name = 'hist_file_config_nl' @@ -22,7 +26,8 @@ module cam_hist_config_file integer, parameter, private :: UNSET_I = -1 character(len=vlen), parameter, private :: UNSET_C = 'UNSET' - type :: hist_file_config_t + type :: hist_file_t + ! History file configuration information character(len=vlen), private :: volume = UNSET_C integer, private :: rl_kind = OUTPUT_DEF integer, private :: max_frames = UNSET_I @@ -32,6 +37,8 @@ module cam_hist_config_file logical, private :: is_sat_track_file = .false. logical, private :: collect_patch_output = PATCH_DEF type(interp_info_t), pointer, private :: interp_info => NULL() + ! History file information + type(file_desc_t), private :: hist_file contains ! Accessors procedure :: filename => config_filename @@ -44,7 +51,7 @@ module cam_hist_config_file procedure :: reset => config_reset procedure :: configure => config_configure procedure :: print_config => config_print_config - end type hist_file_config_t + end type hist_file_t private :: count_array ! Number of non-blank strings in array private :: read_namelist_entry ! Read a namelist group and create config @@ -57,7 +64,7 @@ function config_filename(this, filename_spec) result(cfile) use shr_kind_mod, only: CL => SHR_KIND_CL use cam_filenames, only: interpret_filename_spec ! Dummy arguments - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this character(len=*), optional, intent(in) :: filename_spec character(len=CL) :: cfile @@ -73,7 +80,7 @@ end function config_filename function config_precision(this) result(cprec) ! Dummy arguments - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this character(len=vlen) :: cprec if (this%rl_kind == REAL32) then @@ -89,7 +96,7 @@ end function config_precision integer function config_max_frame(this) ! Dummy argument - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this config_max_frame = this%max_frames end function config_max_frame @@ -100,7 +107,7 @@ function config_output_freq(this) result(out_freq) use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS use shr_string_mod, only: to_lower => shr_string_toLower ! Dummy arguments - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this character(len=CL) :: out_freq ! Local variable character(len=CS) :: out_opt @@ -127,7 +134,7 @@ end function config_output_freq logical function config_init_value_file(this) ! Dummy argument - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this config_init_value_file = this%is_init_val_file @@ -137,7 +144,7 @@ end function config_init_value_file logical function config_satellite_file(this) ! Dummy argument - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this config_satellite_file = this%is_sat_track_file @@ -147,7 +154,7 @@ end function config_satellite_file subroutine config_reset(this) ! Dummy argument - class(hist_file_config_t), intent(inout) :: this + class(hist_file_t), intent(inout) :: this this%collect_patch_output = PATCH_DEF this%rl_kind = OUTPUT_DEF @@ -173,7 +180,7 @@ subroutine config_configure(this, volume, out_prec, max_frames, & use cam_abortutils, only: endrun use string_utils, only: parse_multiplier ! Dummy arguments - class(hist_file_config_t), intent(inout) :: this + class(hist_file_t), intent(inout) :: this character(len=*), intent(in) :: volume integer, intent(in) :: out_prec integer, intent(in) :: max_frames @@ -233,7 +240,7 @@ subroutine config_print_config(this) use spmd_utils, only: masterproc use cam_logfile, only: iulog ! Dummy argument - class(hist_file_config_t), intent(in) :: this + class(hist_file_t), intent(in) :: this if (masterproc) then write(iulog, '(2a)') "History configuration for volume = ", & @@ -307,13 +314,13 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & ! This routine assumes that is positioned at the beginning of ! a history file configuration namelist entry ! Dummy arguments - integer, intent(inout) :: unitn - type(hist_file_config_t), intent(inout) :: hfile_config - character(len=*), intent(inout) :: hist_inst_fields(:) - character(len=*), intent(inout) :: hist_avg_fields(:) - character(len=*), intent(inout) :: hist_min_fields(:) - character(len=*), intent(inout) :: hist_max_fields(:) - character(len=*), intent(inout) :: hist_var_fields(:) + integer, intent(inout) :: unitn + type(hist_file_t), intent(inout) :: hfile_config + character(len=*), intent(inout) :: hist_inst_fields(:) + character(len=*), intent(inout) :: hist_avg_fields(:) + character(len=*), intent(inout) :: hist_min_fields(:) + character(len=*), intent(inout) :: hist_max_fields(:) + character(len=*), intent(inout) :: hist_var_fields(:) ! Local variables (namelist) character(len=vlen) :: hist_volume ! h# ir i, not config number character(len=vlen) :: hist_precision @@ -365,10 +372,6 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & if (ierr /= 0) then call endrun(subname//"ERROR "//trim(to_str(ierr))// & " reading namelist", file=__FILE__, line=__LINE__) -!!XXgoldyXX: v debug only - write(6, *) subname, "ERROR ", ierr, " reading namelist" - return -!!XXgoldyXX: ^ debug only end if ! Translate select case(trim(hist_file_type)) @@ -509,10 +512,7 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & write(errmsg, '(2a,i0,a)') subname, ": ERROR ", ierr, & " reading namelist, hist_config_arrays_nl" call endrun(trim(errmsg)) -!!XXgoldyXX: v debug only - write(6, *) trim(errmsg) - return -!!XXgoldyXX: ^ debug only + return ! For testing end if else write(6, *) subname, ": WARNING, no hist_config_arrays_nl ", & @@ -564,8 +564,8 @@ function hist_read_namelist_config(filename) result(config_arr) ! broadcast to other tasks. ! Dummy arguments - character(len=*), intent(in) :: filename - type(hist_file_config_t), pointer :: config_arr(:) + character(len=*), intent(in) :: filename + type(hist_file_t), pointer :: config_arr(:) ! Local variables integer :: unitn integer :: read_status @@ -587,6 +587,7 @@ function hist_read_namelist_config(filename) result(config_arr) nullify(config_arr) unitn = -1 ! Prevent reads on error or wrong tasks ierr = 0 + errmsg = '' if (masterproc) then inquire(file=trim(filename), exist=filefound) if (.not. filefound) then @@ -594,9 +595,7 @@ function hist_read_namelist_config(filename) result(config_arr) "ERROR: could not find history config file '", & trim(filename), "'" call endrun(subname//trim(config_line)) -!!XXgoldyXX: v debug only -return -!!XXgoldyXX: ^ debug only + return ! Needed for testing else open(newunit=unitn, file=trim(filename), status='old', iostat=ierr) line_num = 0 @@ -604,8 +603,10 @@ function hist_read_namelist_config(filename) result(config_arr) end if call MPI_bcast(ierr, 1, MPI_INTEGER, masterprocid, mpicom, ierr) if (ierr /= 0) then - write(errmsg, '(a,i0,2a)') ": Error ", ierr, " opening ", trim(filename) + write(errmsg, '(a,i0,2a)') ": Error ", ierr, " opening ", & + trim(filename) call endrun(subname//trim(errmsg)) + return ! Needed for testing end if ! First, count up the number of history configs in this file num_configs = 0 @@ -617,21 +618,17 @@ function hist_read_namelist_config(filename) result(config_arr) if (read_status == 0) then ! We found a history config, count it num_configs = num_configs + 1 -!!XXgoldyXX: v debug only -write(6, '(a,i0)') "XXG: Found config #", num_configs -!!XXgoldyXX: ^ debug only ! shr_nl_find_group_name leaves the file pointer at the beginning ! of the namelist, move past for the next search read(unitn, '(a)', iostat=read_status) config_line ! Check that the read did not cause trouble if (read_status > 0) then - write(config_line, '(a,i0,3a)') ": Error (", read_status, & + write(errmsg, '(a,i0,3a)') ": Error (", read_status, & ") from '", trim(filename), "'" close(unitn) - call endrun(subname//trim(config_line)) -!!XXgoldyXX: v debug only -return -!!XXgoldyXX: ^ debug only + num_configs = - read_status ! Used for testing + call endrun(subname//trim(errmsg)) + return ! Neede for testing else if (read_status < 0) then ! We reached the end of the file, just quit exit @@ -641,12 +638,30 @@ function hist_read_namelist_config(filename) result(config_arr) exit end if end do + else + config_line = '' ! For testing end if ! All tasks allocate the history config file objects call MPI_bcast(num_configs, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + ! This block is used for testing + if ((num_configs < 0) .or. (LEN_TRIM(errmsg) > 0)) then + call endrun(subname//trim(errmsg)) + return ! Needed for testing + end if allocate(config_arr(num_configs), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'config_arr', errmsg=errmsg, & file=__FILE__, line=__LINE__-2) + ! This block is needed for testing + if (ierr /= 0) then + return + end if ! End test + ! This block is needed for testing + if (masterproc) then + inquire(unit=unitn, opened=filefound, iostat=ierr) + if ((ierr > 0) .or. (.not. filefound)) then + return + end if + end if ! End test ! Allocate the config field name arrays call allocate_field_arrays(unitn, hist_inst_fields, hist_avg_fields, & hist_min_fields, hist_max_fields, hist_var_fields) @@ -665,10 +680,6 @@ function hist_read_namelist_config(filename) result(config_arr) " in '", trim(filename), "'" close(unitn) call endrun(trim(errmsg)) -!!XXgoldyXX: v debug only -write(6, *) trim(errmsg) -return -!!XXgoldyXX: ^ debug only end if end if call read_namelist_entry(unitn, config_arr(lindex), & @@ -678,6 +689,11 @@ function hist_read_namelist_config(filename) result(config_arr) ! ! Cleanup ! + ! Special block for testing + call MPI_bcast(read_status, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + if (read_status /= 0) then + return + end if ! Close unitn if it is still open inquire(unit=unitn, opened=filefound, iostat=ierr) if ((ierr == 0) .and. filefound) then @@ -700,4 +716,4 @@ function hist_read_namelist_config(filename) result(config_arr) end if end function hist_read_namelist_config -end module cam_hist_config_file +end module cam_hist_file diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 8fe8b23f..9f61308c 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -6,24 +6,14 @@ module cam_history ! It maintains the lists of fields that are written to each history file, ! and the associated metadata for those fields such as descriptive names, ! physical units, time axis properties, etc. - ! It also contains the programmer interface which provides routines that - ! are called from the physics and dynamics initialization routines to - ! define the fields that are produced by the model and are available for - ! output, and the routine that is called from the corresponding run - ! method to add the field values into a history buffer so that they - ! may be output to disk. - ! - ! There are two special history files. The initial file and the - ! satellite track file. ! ! Public functions/subroutines: - ! addfld, add_default - ! hist_init_files - ! history_initialized - ! write_restart_history - ! read_restart_history - ! outfld - ! wshist + ! cam_hist_init_files + ! cam_hist_write_history_state + ! cam_hist_write_restart + ! cam_hist_read_restart + ! cam_hist_capture_field + ! cam_hist_write_history_files !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 @@ -37,29 +27,32 @@ module cam_history use cam_abortutils, only: endrun use cam_logfile, only: iulog - use cam_history_support, only: max_fieldname_len - use cam_history_support, only: fieldname_suffix_len - use cam_history_support, only: max_chars - use cam_history_support, only: pfiles - use cam_history_support, only: fieldname_len - use cam_history_support, only: max_string_len - use cam_history_support, only: date2yyyymmdd - use cam_history_support, only: pflds - use cam_history_support, only: fieldname_lenp2 - use cam_history_support, only: sec2hms - use cam_history_support, only: field_info - use cam_history_support, only: active_entry - use cam_history_support, only: hentry - use cam_history_support, only: horiz_only - use cam_history_support, only: write_hist_coord_attrs - use cam_history_support, only: write_hist_coord_vars - use cam_history_support, only: interp_info_t - use cam_history_support, only: lookup_hist_coord_indices - use cam_history_support, only: get_hist_coord_index - use sat_hist, only: is_satfile - use solar_parms_data, only: solar_parms_define, solar_parms_write - use solar_wind_data, only: solar_wind_define, solar_wind_write - use epotential_params, only: epot_active, epot_crit_colats + use cam_hist_config_file, only: hist_file_config_t +!!XXgoldyXX: v remove unused +! use cam_history_support, only: max_fieldname_len +! use cam_history_support, only: fieldname_suffix_len +! use cam_history_support, only: max_chars +! use cam_history_support, only: pfiles +! use cam_history_support, only: fieldname_len +! use cam_history_support, only: max_string_len +! use cam_history_support, only: date2yyyymmdd +! use cam_history_support, only: pflds +! use cam_history_support, only: fieldname_lenp2 +! use cam_history_support, only: sec2hms +! use cam_history_support, only: field_info +! use cam_history_support, only: active_entry +! use cam_history_support, only: hentry +! use cam_history_support, only: horiz_only +! use cam_history_support, only: write_hist_coord_attrs +! use cam_history_support, only: write_hist_coord_vars +! use cam_history_support, only: interp_info_t +! use cam_history_support, only: lookup_hist_coord_indices +! use cam_history_support, only: get_hist_coord_index +! use sat_hist, only: is_satfile +! use solar_parms_data, only: solar_parms_define, solar_parms_write +! use solar_wind_data, only: solar_wind_define, solar_wind_write +! use epotential_params, only: epot_active, epot_crit_colats +!!XXgoldyXX: ^ remove unused implicit none private @@ -78,12 +71,8 @@ module cam_history character(len=16) :: host ! host name character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or ! 'YEARLY' then write IC file - logical :: inithist_all = .false. ! Flag to indicate set of fields to be - ! included on IC file - ! .false. include only required fields - ! .true. include required *and* optional fields - integer :: maxvarmdims=1 + integer, private :: maxvarmdims = 1 ! ! @@ -93,10 +82,6 @@ module cam_history character(len=max_string_len) :: rhfilename_spec = '%c.cam.rh%t.%y-%m-%d-%s.nc' ! history restart character(len=max_string_len) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) ! filename specifyer - - ! Needed by cam_diagnostics - public :: inithist_all - integer :: lcltod_start(pfiles) ! start time of day for local time averaging (sec) integer :: lcltod_stop(pfiles) ! stop time of day for local time averaging, stop > start is wrap around (sec) @@ -107,8 +92,7 @@ module cam_history public :: history_read_restart ! Read restart history data public :: history_write_files ! Write files out ! public :: outfld ! Output a field - public :: history_init_files ! Initialization - public :: history_initialized ! .true. iff cam history initialized + public :: cam_hist_init_files ! Initialization public :: history_finalize ! process history files at end of run public :: history_write_IC ! flag to dump of IC to IC file public :: history_addfld ! Add a field to history file @@ -116,12 +100,14 @@ module cam_history public :: history_fld_col_active ! .true. for each column where a field is active on any history file public :: register_vector_field ! Register vector field set for interpolated output + ! Private data + type(hist_file_config_t), pointer :: hist_configs(:) + CONTAINS subroutine history_readnl(nlfile) use spmd_utils, only: masterproc, masterprocid, mpicom use spmd_utils, only: mpi_integer, mpi_logical, mpi_character - use cam_hist_config_file, only: hist_file_config_t use cam_hist_config_file, only: hist_read_namelist_config use time_manager, only: get_step_size @@ -133,7 +119,13 @@ subroutine history_readnl(nlfile) integer :: dtime ! Step time in seconds integer :: unitn, ierr character(len=8) :: ctemp ! Temporary character string - ! History file write times + + ! Read in CAM history configuration + hist_configs => hist_read_namelist_config(nlfile) + if (check_endrun(test_desc=test_msg, output=out_unit)) then + err_cnt = err_cnt + 1 + end if + ! History file write times ! Convert write freq. of hist files from hours to timesteps if necessary. ! dtime = get_step_size() @@ -257,7 +249,7 @@ end subroutine history_readnl !=========================================================================== - subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) + subroutine cam_hist_init_files(model_doi_url_in, caseid_in, ctitle_in) ! !----------------------------------------------------------------------- ! @@ -417,11 +409,7 @@ subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) call sat_hist_init() return - end subroutine hist_init_files - - logical function history_initialized() - history_initialized = associated(masterlist) - end function history_initialized + end subroutine cam_hist_init_files !=========================================================================== @@ -621,7 +609,7 @@ subroutine write_restart_history(File, & return end if - call wshist(regen_hist_file) + call cam_hist_write_history_files(regen_hist_file) file => history_file @@ -3780,7 +3768,7 @@ logical function write_inithist () !----------------------------------------------------------------------- ! ! Purpose: Set flags that will initiate dump to IC file when OUTFLD and - ! WSHIST are called + ! CAM_HIST_WRITE_HISTORY_FILES are called ! !----------------------------------------------------------------------- ! @@ -3824,7 +3812,7 @@ end function write_inithist !####################################################################### - subroutine wshist(regen_hist_file_in) + subroutine cam_hist_write_history_files(regen_hist_file_in) ! !----------------------------------------------------------------------- ! @@ -3871,6 +3859,7 @@ subroutine wshist(regen_hist_file_in) integer :: tsec ! day component of current time integer :: dtime ! seconds component of current time #endif + character(len=*), parameter :: subname = 'cam_hist_write_history_files' if(present(regen_hist_file_in)) then regen_hist_file = regen_hist_file_in @@ -3914,20 +3903,20 @@ subroutine wshist(regen_hist_file_in) if (write_file(fil_idx) .or. (restart .and. regen_hist_file(fil_idx))) then if(masterproc) then if(is_initfile(file_index=t)) then - write(iulog,100) yr,mon,day,ncsec -100 format('WSHIST: writing time sample to Initial Conditions h-file', & - ' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + write(iulog, '(3a,i4.4,2(a,i2.2),a,i6)') subname, & + ': writing time sample to Initial Conditions h-file', & + ' DATE = ', yr, '/', mon, '/', day, 'NCSEC = ', ncsec else if(is_satfile(fil_idx)) then write(iulog,150) nfils(fil_idx),t,yr,mon,day,ncsec -150 format('WSHIST: writing sat columns ',i6,' to h-file ', & +150 format(subname//': writing sat columns ',i6,' to h-file ', & i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) else if(write_file(fil_idx)) then write(iulog,200) nfils(fil_idx),t,yr,mon,day,ncsec -200 format('WSHIST: writing time sample ',i3,' to h-file ', & +200 format(subname//': writing time sample ',i3,' to h-file ', & i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) else if(restart .and. regen_hist_file(fil_idx)) then write(iulog,300) nfils(fil_idx),t,yr,mon,day,ncsec -300 format('WSHIST: writing history restart ',i3,' to hr-file ', & +300 format(subname//': writing history restart ',i3,' to hr-file ', & i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) end if write(iulog,*) @@ -3952,7 +3941,7 @@ subroutine wshist(regen_hist_file_in) ! do f = 1, pfiles if (masterproc.and. trim(fname) == trim(nhfil(fld_idx)) )then - write(iulog,*)'WSHIST: New filename same as old file = ', trim(fname) + write(iulog,*)subname//': New filename same as old file = ', trim(fname) write(iulog,*)'Is there an error in your filename specifiers?' write(iulog,*)'hfilename_spec(', t, ') = ', hfilename_spec(fil_idx) if ( t /= f )then @@ -3963,7 +3952,7 @@ subroutine wshist(regen_hist_file_in) end do if(.not. restart) then nhfil(fil_idx) = fname - if(masterproc) write(iulog,*)'WSHIST: nhfil(',t,')=',trim(nhfil(fil_idx)) + if(masterproc) write(iulog,*)subname//': nhfil(',t,')=',trim(nhfil(fil_idx)) cpath(fil_idx) = nhfil(fil_idx) end if call h_define (t, restart) @@ -4089,7 +4078,7 @@ subroutine wshist(regen_hist_file_in) end do return - end subroutine wshist + end subroutine cam_hist_write_history_files !####################################################################### diff --git a/test/hist_tests/CMakeLists.txt b/test/hist_tests/CMakeLists.txt index b2074879..87a5f8a2 100644 --- a/test/hist_tests/CMakeLists.txt +++ b/test/hist_tests/CMakeLists.txt @@ -37,6 +37,7 @@ LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_assert_mod.F90") LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_string_mod.F90") LIST(APPEND SOURCE_FILES "${UTILS_PATH}/time_manager.F90") LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_control_mod.F90") +LIST(APPEND SOURCE_FILES "${UTILS_PATH}/pio.F90") LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_interp_mod.F90") LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_history_support.F90") # Regular CAM and CIME utility files @@ -51,7 +52,7 @@ LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_strconvert_mod.F90") LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_filenames.F90") # CAM history files -LIST(APPEND SOURCE_FILES "${HIST_PATH}/cam_hist_config_file.F90") +LIST(APPEND SOURCE_FILES "${HIST_PATH}/cam_hist_file.F90") ## We need to copy shr_assert.h into this directory #configure_file("${CIME_PATH}/src/share/util/shr_assert.h" # "${CMAKE_CURRENT_SOURCE_DIR}/shr_assert.h" COPYONLY) @@ -133,6 +134,8 @@ else(OPENMP) message (STATUS "Disable OpenMP support for C/C++/Fortran compiler") endif() TARGET_SOURCES(${TEST_EXE} PUBLIC ${SOURCE_FILES}) +# Allow include files in ../include +TARGET_INCLUDE_DIRECTORIES(${TEST_EXE} PRIVATE ${UTILS_PATH}) TARGET_LINK_LIBRARIES(${TEST_EXE} ${MPI_Fortran_LIBRARIES}) set_target_properties(${TEST_EXE} PROPERTIES diff --git a/test/hist_tests/run_test b/test/hist_tests/run_test new file mode 100755 index 00000000..39d44ccb --- /dev/null +++ b/test/hist_tests/run_test @@ -0,0 +1,146 @@ +#! /bin/bash + +currdir="`pwd -P`" +scriptdir="$( cd $( dirname $0 ); pwd -P )" + +## +## Option default values +## +defdir="build" +build_dir="${currdir}/${defdir}" +cleanup="PASS" # Other supported options are ALWAYS and NEVER +verbosity=0 + +## +## General syntax help function +## Usage: help +## +help () { + local hname="Usage: `basename ${0}`" + local hprefix="`echo ${hname} | tr '[!-~]' ' '`" + echo "${hname} [ --build-dir ] [ --cleanup ]" + hprefix=" " + echo "" + echo "${hprefix} : Directory for building and running the test" + echo "${hprefix} default is /${defdir}" + echo "${hprefix} : Cleanup option is ALWAYS, NEVER, or PASS" + echo "${hprefix} default is PASS" + exit $1 +} + +## +## Error output function (should be handed a string) +## +perr() { + >&2 echo -e "\nERROR: ${@}\n" + exit 1 +} + +## +## Cleanup the build and test directory +## +docleanup() { + # We start off in the build directory + if [ "${build_dir}" == "${currdir}" ]; then + echo "WARNING: Cannot clean ${build_dir}" + else + cd ${currdir} + rm -rf ${build_dir} + fi +} + +## Process our input arguments +while [ $# -gt 0 ]; do + case $1 in + --h | -h | --help | -help) + help 0 + ;; + --build-dir) + if [ $# -lt 2 ]; then + perr "${1} requires a build directory" + fi + build_dir="${2}" + shift + ;; + --cleanup) + if [ $# -lt 2 ]; then + perr "${1} requies a cleanup option (ALWAYS, NEVER, PASS)" + fi + if [ "${2}" == "ALWAYS" -o "${2}" == "NEVER" -o "${2}" == "PASS" ]; then + cleanup="${2}" + else + perr "Allowed cleanup options: ALWAYS, NEVER, PASS" + fi + shift + ;; + *) + perr "Unrecognized option, \"${1}\"" + ;; + esac + shift +done + +# Create the build directory, if necessary +if [ -d "${build_dir}" ]; then + # Always make sure build_dir is not in the test dir + if [ "$( cd ${build_dir}; pwd -P )" == "${currdir}" ]; then + build_dir="${build_dir}/${defdir}" + fi +else + mkdir -p ${build_dir} + res=$? + if [ $res -ne 0 ]; then + perr "Unable to create build directory, '${build_dir}'" + fi +fi +build_dir="$( cd ${build_dir}; pwd -P )" +sampledir="${scriptdir}/sample_files" +if [ ! -d "${sampledir}" ]; then + perr "No samples files directory found at '${sampledir}'" +fi + +# cd to the build directory +cd ${build_dir} +res=$? +if [ $res -ne 0 ]; then + perr "Unable to cd to build directory, '${build_dir}'" +fi +# Clean build directory +rm -rf * +res=$? +if [ $res -ne 0 ]; then + perr "Unable to clean build directory, '${build_dir}'" +fi +# Run CMake +opts="" +cmake ${scriptdir} ${opts} +res=$? +if [ $res -ne 0 ]; then + perr "CMake failed with exit code, ${res}" +fi +# Run make +make +res=$? +if [ $res -ne 0 ]; then + perr "make failed with exit code, ${res}" +fi +# Run test with 1 task +mpirun -n 1 ./test_history ${sampledir} +res=$? +if [ $res -ne 0 ]; then + perr "test_history with one task failed with exit code, ${res}" +fi +# Run test with 4 tasks +mpirun -n 4 ./test_history ${sampledir} +res=$? +if [ $res -ne 0 ]; then + perr "test_history with four tasks failed with exit code, ${res}" +fi + +if [ "${cleanup}" == "ALWAYS" ]; then + docleanup +elif [ $res -eq 0 -a "${cleanup}" == "PASS" ]; then + docleanup +fi + +exit $res diff --git a/test/hist_tests/test_history.F90 b/test/hist_tests/test_history.F90 index a7f50e73..18131933 100644 --- a/test/hist_tests/test_history.F90 +++ b/test/hist_tests/test_history.F90 @@ -12,8 +12,8 @@ subroutine run_test(test_msg, test_file, sample_dir, out_unit, & test_cnt, err_cnt) use shr_kind_mod, only: max_flen=>SHR_KIND_CL use cam_abortutils, only: endrun, check_endrun - use cam_hist_config_file, only: hist_file_config_t - use cam_hist_config_file, only: hist_read_namelist_config + use cam_hist_file, only: hist_file_t + use cam_hist_file, only: hist_read_namelist_config ! Dummy arguments character(len=*), intent(in) :: test_msg @@ -27,9 +27,9 @@ subroutine run_test(test_msg, test_file, sample_dir, out_unit, & integer, intent(out) :: test_cnt integer, intent(out) :: err_cnt ! Local variables - type(hist_file_config_t), pointer :: tconfig_arr(:) - character(len=max_flen) :: test_path - integer :: indx + type(hist_file_t), pointer :: tconfig_arr(:) + character(len=max_flen) :: test_path + integer :: indx test_cnt = 0 err_cnt = 0 @@ -91,25 +91,25 @@ end module test_hist_mod program test_history - use shr_kind_mod, only: max_chars=>SHR_KIND_CX - use shr_kind_mod, only: max_flen=>SHR_KIND_CL - use cam_abortutils, only: endrun, check_endrun - use cam_hist_config_file, only: hist_file_config_t - use cam_hist_config_file, only: hist_read_namelist_config - use test_hist_mod, only: run_test + use shr_kind_mod, only: max_chars=>SHR_KIND_CX + use shr_kind_mod, only: max_flen=>SHR_KIND_CL + use cam_abortutils, only: endrun, check_endrun + use cam_hist_file, only: hist_file_t + use cam_hist_file, only: hist_read_namelist_config + use test_hist_mod, only: run_test implicit none - integer :: out_unit = 6 - integer :: ierr - integer :: errcnt - integer :: testcnt - integer :: total_errcnt = 0 - integer :: total_tests = 0 - character(len=max_flen) :: sample_dir - character(len=max_flen) :: test_file - character(len=max_chars) :: test_msg - type(hist_file_config_t), pointer :: test_config_arr(:) + integer :: out_unit = 6 + integer :: ierr + integer :: errcnt + integer :: testcnt + integer :: total_errcnt = 0 + integer :: total_tests = 0 + character(len=max_flen) :: sample_dir + character(len=max_flen) :: test_file + character(len=max_chars) :: test_msg + type(hist_file_t), pointer :: test_config_arr(:) => NULL() ! Get sample directory from command line errcnt = command_argument_count() diff --git a/test/include/config.h b/test/include/config.h new file mode 100644 index 00000000..e69de29b diff --git a/test/include/pio.F90 b/test/include/pio.F90 new file mode 100644 index 00000000..e60a995c --- /dev/null +++ b/test/include/pio.F90 @@ -0,0 +1,12 @@ +module pio + + !! Fake PIO types and interfaces for testing + + implicit none + private + + type, public :: file_desc_t + character(len=32) :: name = "Fake PIO file descriptor" + end type file_desc_t + +end module pio From ab8eb89f42daa103f89de9e9f0e721fd962cacc4 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Sat, 6 Aug 2022 22:33:30 -0600 Subject: [PATCH 05/79] Added history external --- Externals_CAM.cfg | 19 +++++++++++++------ src/history/cam_history.F90 | 14 +++++++------- 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 2fe3eef2..eb0538cf 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -5,6 +5,13 @@ repo_url = https://github.com/gold2718/ccpp-framework tag = CPF_0.2.032 required = True +[clubb] +local_path = src/physics/clubb +protocol = svn +repo_url = https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_tags/ +tag = clubb_ncar_backwards_compat_20181205_c20190528 +required = False + [cosp2] local_path = src/physics/cosp2/src protocol = svn @@ -12,12 +19,12 @@ repo_url = https://github.com/CFMIP/COSPv2.0/tags/ tag = v2.0.3cesm/src required = False -[clubb] -local_path = src/physics/clubb -protocol = svn -repo_url = https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_tags/ -tag = clubb_ncar_backwards_compat_20181205_c20190528 -required = False +[history] +local_path = src/history/buffers +protocol = git +repo_url = https://github.com/gold2718/history_output +branch = camden_history +required = True [ncar-physics] local_path = src/physics/ncar_ccpp diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 9f61308c..6ec8f12d 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -112,13 +112,13 @@ subroutine history_readnl(nlfile) use time_manager, only: get_step_size ! Dummy argument - character(len=*), intent(in) :: nlfile ! filepath of namelist input file + character(len=*), intent(in) :: nlfile ! path of namelist input file ! ! Local variables - integer :: dtime ! Step time in seconds - integer :: unitn, ierr - character(len=8) :: ctemp ! Temporary character string + integer :: dtime ! Step time in seconds + integer :: unitn, ierr + character(len=8) :: ctemp ! Temporary character string ! Read in CAM history configuration hist_configs => hist_read_namelist_config(nlfile) @@ -126,9 +126,9 @@ subroutine history_readnl(nlfile) err_cnt = err_cnt + 1 end if ! History file write times - ! Convert write freq. of hist files from hours to timesteps if necessary. - ! - dtime = get_step_size() + ! Convert write freq. of hist files from hours to timesteps if necessary. + ! + dtime = get_step_size() do t = 1, pfiles if (hist_freq(fil_idx) < 0) then hist_freq(fil_idx) = nint((-hist_freq(fil_idx) * 3600._r8) / dtime) From 478905bb705c9e1e9ef3eda1fdff538f88cd41cc Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Sat, 11 Feb 2023 00:10:30 +0100 Subject: [PATCH 06/79] Checkin to work on other branch --- src/history/cam_hist_file.F90 | 8 +-- src/history/cam_history.F90 | 112 ++++++++++++---------------------- 2 files changed, 44 insertions(+), 76 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 169ca925..a7ae4045 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -60,13 +60,13 @@ module cam_hist_file ! ======================================================================== - function config_filename(this, filename_spec) result(cfile) + function config_filename(this, inst_suffix) result(cfile) use shr_kind_mod, only: CL => SHR_KIND_CL use cam_filenames, only: interpret_filename_spec ! Dummy arguments - class(hist_file_t), intent(in) :: this - character(len=*), optional, intent(in) :: filename_spec - character(len=CL) :: cfile + class(hist_file_t), intent(in) :: this + character(len=*), intent(in) :: inst_suffix + character(len=CL) :: cfile if (present(filename_spec)) then cfile = interpret_filename_spec(filename_spec, unit=this%volume) diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 6ec8f12d..10d732d3 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -17,7 +17,7 @@ module cam_history !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use shr_kind_mod, only: cl=>SHR_KIND_CL + use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX use shr_sys_mod, only: shr_sys_flush use perf_mod, only: t_startf, t_stopf use spmd_utils, only: masterproc @@ -28,31 +28,6 @@ module cam_history use cam_logfile, only: iulog use cam_hist_config_file, only: hist_file_config_t -!!XXgoldyXX: v remove unused -! use cam_history_support, only: max_fieldname_len -! use cam_history_support, only: fieldname_suffix_len -! use cam_history_support, only: max_chars -! use cam_history_support, only: pfiles -! use cam_history_support, only: fieldname_len -! use cam_history_support, only: max_string_len -! use cam_history_support, only: date2yyyymmdd -! use cam_history_support, only: pflds -! use cam_history_support, only: fieldname_lenp2 -! use cam_history_support, only: sec2hms -! use cam_history_support, only: field_info -! use cam_history_support, only: active_entry -! use cam_history_support, only: hentry -! use cam_history_support, only: horiz_only -! use cam_history_support, only: write_hist_coord_attrs -! use cam_history_support, only: write_hist_coord_vars -! use cam_history_support, only: interp_info_t -! use cam_history_support, only: lookup_hist_coord_indices -! use cam_history_support, only: get_hist_coord_index -! use sat_hist, only: is_satfile -! use solar_parms_data, only: solar_parms_define, solar_parms_write -! use solar_wind_data, only: solar_wind_define, solar_wind_write -! use epotential_params, only: epot_active, epot_crit_colats -!!XXgoldyXX: ^ remove unused implicit none private @@ -64,9 +39,9 @@ module cam_history ! NB: This name must match the group name in namelist_definition.xml character(len=*), parameter :: history_namelist = 'cam_history_nl' ! hrestpath: Full history restart pathnames - character(len=max_string_len) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) - character(len=max_string_len) :: cpath(pfiles) ! Array of current pathnames - character(len=max_string_len) :: nhfil(pfiles) ! Array of current file names + character(len=cxx) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) + character(len=cxx) :: cpath(pfiles) ! Array of current pathnames + character(len=cxx) :: nhfil(pfiles) ! Array of current file names character(len=16) :: logname ! user name character(len=16) :: host ! host name character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or @@ -77,10 +52,17 @@ module cam_history ! ! Filename specifiers for history, initial files and restart history files - ! (%c = caseid, $y = year, $m = month, $d = day, $s = seconds in day, %t = file number) + ! (%c = caseid, + ! %y = year, + ! %m = month, + ! %d = day, + ! %s = seconds in day, + ! %u = unit number (e.g., h0, i) ! - character(len=max_string_len) :: rhfilename_spec = '%c.cam.rh%t.%y-%m-%d-%s.nc' ! history restart - character(len=max_string_len) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) ! filename specifyer + ! rhfilename_spec is the templdate for history restart files + character(len=cxx) :: rhfilename_spec = '%c.cam.r%u.%y-%m-%d-%s.nc' + ! hfilename_spec is the template for each history file + character(len=cxx) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) integer :: lcltod_start(pfiles) ! start time of day for local time averaging (sec) integer :: lcltod_stop(pfiles) ! stop time of day for local time averaging, stop > start is wrap around (sec) @@ -91,11 +73,11 @@ module cam_history public :: history_write_restart ! Write restart history data public :: history_read_restart ! Read restart history data public :: history_write_files ! Write files out -! public :: outfld ! Output a field - public :: cam_hist_init_files ! Initialization + public :: cam_hist_init_files ! Initialization public :: history_finalize ! process history files at end of run public :: history_write_IC ! flag to dump of IC to IC file - public :: history_addfld ! Add a field to history file + public :: history_define_fld ! Add a field to history file + public :: history_capture_fld ! Capture current state of a model field public :: history_fld_active ! .true. if a field is active on any history file public :: history_fld_col_active ! .true. for each column where a field is active on any history file public :: register_vector_field ! Register vector field set for interpolated output @@ -106,10 +88,10 @@ module cam_history CONTAINS subroutine history_readnl(nlfile) - use spmd_utils, only: masterproc, masterprocid, mpicom - use spmd_utils, only: mpi_integer, mpi_logical, mpi_character - use cam_hist_config_file, only: hist_read_namelist_config - use time_manager, only: get_step_size + use spmd_utils, only: masterproc, masterprocid, mpicom + use spmd_utils, only: mpi_integer, mpi_logical, mpi_character + use cam_hist_file, only: hist_read_namelist_config + use time_manager, only: get_step_size ! Dummy argument character(len=*), intent(in) :: nlfile ! path of namelist input file @@ -125,45 +107,31 @@ subroutine history_readnl(nlfile) if (check_endrun(test_desc=test_msg, output=out_unit)) then err_cnt = err_cnt + 1 end if - ! History file write times - ! Convert write freq. of hist files from hours to timesteps if necessary. ! - dtime = get_step_size() - do t = 1, pfiles - if (hist_freq(fil_idx) < 0) then - hist_freq(fil_idx) = nint((-hist_freq(fil_idx) * 3600._r8) / dtime) + ! Initialize the filename specifier if not already set + ! This is the format for the history filenames: + ! %c= caseid, %t=file no., %y=year, %m=month, %d=day, %s=second, %%=% + ! See the filenames module for more information + ! + do t = 1, pfiles + if ( len_trim(hfilename_spec(fil_idx)) == 0 )then + if ( hist_freq(fil_idx) == 0 )then + ! Monthly files + hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // & + '.%u.%y-%m.nc' + else + hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // & + '.%u.%y-%m-%d-%s.nc' end if - end do - ! - ! Initialize the filename specifier if not already set - ! This is the format for the history filenames: - ! %c= caseid, %t=file no., %y=year, %m=month, %d=day, %s=second, %%=% - ! See the filenames module for more information + end if ! - do t = 1, pfiles - if ( len_trim(hfilename_spec(fil_idx)) == 0 )then - if ( hist_freq(fil_idx) == 0 )then - ! Monthly files - hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // '.h%t.%y-%m.nc' - else - hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // '.h%t.%y-%m-%d-%s.nc' - end if - end if - ! - ! Only one time sample allowed per monthly average file - ! - if (hist_freq(fil_idx) == 0) then - mfilt(fil_idx) = 1 - end if - end do - end if ! masterproc ! Print per-file averaging flags if (masterproc) then do t = 1, pfiles if (avgflag_perfile(fil_idx) /= ' ') then - write(iulog,*)'Unless overridden by namelist input on a per-field basis (FINCL),' - write(iulog,*)'All fields on history file ',t,' will have averaging flag ',avgflag_perfile(fil_idx) + write(iulog, *) 'Unless overridden by namelist input on a per-field basis (FINCL),' + write(iulog,*) 'All fields on history file ',t,' will have averaging flag ',avgflag_perfile(fil_idx) end if ! Enforce no interpolation for satellite files if (is_satfile(fil_idx) .and. interpolate_output(fil_idx)) then @@ -653,7 +621,7 @@ subroutine read_restart_history (fil_idx) integer regen_hist_int(pfiles) integer :: ierr - character(len=max_string_len) :: locfn ! Local filename + character(len=cxx) :: locfn ! Local filename character(len=max_fieldname_len), allocatable :: tmpname(:,:) integer, allocatable :: decomp(:,:), tmpnumlev(:,:) integer, pointer :: nacs(:,:) ! accumulation counter @@ -3852,7 +3820,7 @@ subroutine cam_hist_write_history_files(regen_hist_file_in) integer :: nscur ! seconds component of current time real(r8) :: time ! current time real(r8) :: tdata(2) ! time interval boundaries - character(len=max_string_len) :: fname ! Filename + character(len=cxx) :: fname ! Filename logical :: prev ! Label file with previous date rather than current integer :: ierr #if ( defined BFB_CAM_SCAM_IOP ) From 70dd48348bf2474e58e9fcffbbf01bddd910c617 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Wed, 22 Mar 2023 13:43:11 +0100 Subject: [PATCH 07/79] Partial implementation of filename spec in new initialization scheme. --- cime_config/hist_config.py | 2 + src/history/cam_hist_file.F90 | 111 +++++++++++++++++++++++----------- src/history/cam_history.F90 | 39 ++++-------- 3 files changed, 92 insertions(+), 60 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 70c89258..b7f97789 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -787,6 +787,8 @@ def output_config_namelist(self, outfile): HistoryVolConfig.set_precision), HistConfigEntry(r"hist_diag_file", _is_filename, None), + HistConfigEntry(r"hist_filename_template", + _is_filename, None), HistConfigEntry(r"hist_remove_fields", _list_of_idents, HistoryVolConfig.remove_fields)] diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index a7ae4045..bf673cac 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -26,27 +26,35 @@ module cam_hist_file integer, parameter, private :: UNSET_I = -1 character(len=vlen), parameter, private :: UNSET_C = 'UNSET' + integer, parameter, private :: hfile_type_default = -1 + integer, parameter, private :: hfile_type_history = 1 + integer, parameter, private :: hfile_type_init_value = 2 + integer, parameter, private :: hfile_type_sat_track = 3 + integer, parameter, private :: hfile_type_restart = 4 + type :: hist_file_t ! History file configuration information - character(len=vlen), private :: volume = UNSET_C - integer, private :: rl_kind = OUTPUT_DEF - integer, private :: max_frames = UNSET_I - integer, private :: output_freq_mult = UNSET_I - character(len=8), private :: output_freq_type = UNSET_C - logical, private :: is_init_val_file = .false. - logical, private :: is_sat_track_file = .false. - logical, private :: collect_patch_output = PATCH_DEF - type(interp_info_t), pointer, private :: interp_info => NULL() + character(len=vlen), private :: volume = UNSET_C + integer, private :: rl_kind = OUTPUT_DEF + integer, private :: max_frames = UNSET_I + integer, private :: output_freq_mult = UNSET_I + character(len=8), private :: output_freq_type = UNSET_C + character(len=*), allocatable, private :: filename_spec + integer, private :: hfile_type = hfile_type_default + logical, private :: collect_patch_output = PATCH_DEF + type(interp_info_t), pointer, private :: interp_info => NULL() ! History file information - type(file_desc_t), private :: hist_file + type(file_desc_t), private :: hist_file contains ! Accessors procedure :: filename => config_filename procedure :: precision => config_precision procedure :: max_frame => config_max_frame procedure :: output_freq => config_output_freq + procedure :: is_history_file => config_history_file procedure :: is_initial_value_file => config_init_value_file procedure :: is_satellite_file => config_satellite_file + procedure :: is_hist_restart_file => config_restart_file ! Actions procedure :: reset => config_reset procedure :: configure => config_configure @@ -57,6 +65,19 @@ module cam_hist_file private :: read_namelist_entry ! Read a namelist group and create config CONTAINS + ! + ! Filename specifiers for history, initial files and restart history files + ! %c = caseid, + ! %y = year, + ! %m = month, + ! %d = day, + ! %s = seconds in day, + ! %u = unit number (e.g., h0, i) + ! + ! rhfilename_spec is the templdate for history restart files + character(len=*), parameter :: rhfilename_spec = '%c.cam.r%u.%y-%m-%d-%s.nc' + ! hfilename_spec is the template for each history file + character(len=*), parameter :: hfilename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' ! ======================================================================== @@ -68,11 +89,7 @@ function config_filename(this, inst_suffix) result(cfile) character(len=*), intent(in) :: inst_suffix character(len=CL) :: cfile - if (present(filename_spec)) then - cfile = interpret_filename_spec(filename_spec, unit=this%volume) - else - cfile = this%volume - end if + cfile = interpret_filename_spec(this%filename_spec, unit=this%volume) end function config_filename @@ -132,11 +149,21 @@ end function config_output_freq ! ======================================================================== + logical function config_history_file(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_init_value_file = this%hfile_type == hfile_type_history + + end function config_history_file + + ! ======================================================================== + logical function config_init_value_file(this) ! Dummy argument class(hist_file_t), intent(in) :: this - config_init_value_file = this%is_init_val_file + config_init_value_file = this%hfile_type == hfile_type_init_value end function config_init_value_file @@ -146,12 +173,22 @@ logical function config_satellite_file(this) ! Dummy argument class(hist_file_t), intent(in) :: this - config_satellite_file = this%is_sat_track_file + config_satellite_file = this%hfile_type == hfile_type_sat_track end function config_satellite_file ! ======================================================================== + logical function config_restart_file(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_satellite_file = this%hfile_type == hfile_type_restart + + end function config_restart_file + + ! ======================================================================== + subroutine config_reset(this) ! Dummy argument class(hist_file_t), intent(inout) :: this @@ -173,7 +210,7 @@ end subroutine config_reset ! ======================================================================== subroutine config_configure(this, volume, out_prec, max_frames, & - output_freq, init_file, sat_file, collect_patch_out, & + output_freq, file_type, collect_patch_out, filename_spec, & interp_out, interp_nlat, interp_nlon, interp_grid, interp_type) use shr_kind_mod, only: CL=>SHR_KIND_CL use shr_string_mod, only: to_lower => shr_string_toLower @@ -185,9 +222,9 @@ subroutine config_configure(this, volume, out_prec, max_frames, & integer, intent(in) :: out_prec integer, intent(in) :: max_frames character(len=*), intent(in) :: output_freq - logical, intent(in) :: init_file - logical, intent(in) :: sat_file + integer, intent(in) :: file_type logical, intent(in) :: collect_patch_out + character(len*), intent(in) :: filename_spec logical, optional, intent(in) :: interp_out integer, optional, intent(in) :: interp_nlat integer, optional, intent(in) :: interp_nlon @@ -223,9 +260,9 @@ subroutine config_configure(this, volume, out_prec, max_frames, & if (to_lower(this%output_freq_type(last_char:last_char)) == "s") then this%output_freq_type = this%output_freq_type(1:last_char-1) end if - this%is_init_val_file = init_file - this%is_sat_track_file = sat_file + this%hfile_type = file_type this%collect_patch_output = collect_patch_out + this%filename_spec = filename_spec if (present(interp_out)) then if (interp_out) then allocate(this%interp_info) @@ -303,6 +340,7 @@ end function count_array subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_avg_fields, hist_min_fields, hist_max_fields, hist_var_fields) use mpi, only: MPI_CHARACTER, MPI_INTEGER, MPI_LOGICAL + use shr_kind_mod, only: CL=>SHR_KIND_CL use string_utils, only: to_str use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -328,11 +366,11 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & character(len=flen) :: hist_output_frequency logical :: hist_collect_patch_output character(len=flen) :: hist_file_type + character(len=CL) :: hist_filename_spec ! Local variables (other) integer :: ierr integer :: num_fields - logical :: is_sat_file - logical :: is_init_file + integer :: file_type integer :: rl_kind ! XXgoldyXX: Add patch information logical :: hist_interp_out @@ -347,7 +385,7 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_precision, hist_max_frames, hist_output_frequency, & hist_file_type, hist_collect_patch_output, & hist_interp_out, hist_interp_nlat, hist_interp_nlon, & - hist_interp_grid, hist_interp_type + hist_interp_grid, hist_interp_type, hist_filename_spec ! Initialize namelist entries to default values hist_inst_fields(:) = '' @@ -366,6 +404,8 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_interp_nlon = 0 hist_interp_grid = UNSET_C hist_interp_type = UNSET_C + file_type = hfile_type_default + hist_filename_spec = UNSET_C ! Read namelist entry if (masterproc) then read(unitn, hist_file_config_nl, iostat=ierr) @@ -376,12 +416,13 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & ! Translate select case(trim(hist_file_type)) case(UNSET_C, 'history') - is_sat_file = .false. - is_init_file = .false. - case('satellite') - is_sat_file = .true. + file_type = hfile_type_history case('initial_value') - is_init_file = .true. + file_type = hfile_type_init_value + case('restart') + file_type = hfile_type_restart + case('satellite') + file_type = hfile_type_sat_track case default call endrun(subname//"ERROR, Invalid history file type, '"// & trim(hist_file_type)//"'", file=__FILE__, line=__LINE__) @@ -433,17 +474,19 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & masterprocid, mpicom, ierr) call MPI_Bcast(hist_collect_patch_output, 1, MPI_LOGICAL, & masterprocid, mpicom, ierr) - call MPI_Bcast(is_sat_file, 1, MPI_LOGICAL, masterprocid, mpicom, ierr) - call MPI_Bcast(is_init_file, 1, MPI_LOGICAL, masterprocid, mpicom, ierr) + call MPI_Bcast(file_type, 1, MPI_INTEGER, masterprocid, mpicom, ierr) call MPI_Bcast(hist_interp_grid, flen, MPI_CHARACTER, & masterprocid, mpicom, ierr) call MPI_Bcast(hist_interp_type, flen, MPI_CHARACTER, & masterprocid, mpicom, ierr) + call MPI_Bcast(hist_filename_spec, CL, MPI_CHARACTER, & + masterprocid, mpicom, ierr) ! Configure the history file call hfile_config%configure(hist_volume, rl_kind, hist_max_frames, & - hist_output_frequency, is_init_file, is_sat_file, & + hist_output_frequency, file_type, & hist_collect_patch_output, hist_interp_out, hist_interp_nlat, & - hist_interp_nlon, hist_interp_grid, hist_interp_type) + hist_interp_nlon, hist_interp_grid, hist_interp_type, & + hist_filename_spec) call hfile_config%print_config() end subroutine read_namelist_entry diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 10d732d3..6e8127be 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -16,17 +16,16 @@ module cam_history ! cam_hist_write_history_files !----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX - use shr_sys_mod, only: shr_sys_flush - use perf_mod, only: t_startf, t_stopf - use spmd_utils, only: masterproc - use cam_filenames, only: interpret_filename_spec - use cam_instance, only: inst_suffix - use cam_initfiles, only: ncdata, bnd_topo - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - + use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 + use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX + use shr_sys_mod, only: shr_sys_flush + use perf_mod, only: t_startf, t_stopf + use spmd_utils, only: masterproc + use cam_filenames, only: interpret_filename_spec + use cam_instance, only: inst_suffix + use cam_initfiles, only: ncdata, bnd_topo + use cam_abortutils, only: endrun + use cam_logfile, only: iulog use cam_hist_config_file, only: hist_file_config_t implicit none @@ -36,7 +35,7 @@ module cam_history character(len=cl) :: model_doi_url = '' ! Model DOI character(len=cl) :: caseid = '' ! case ID character(len=cl) :: ctitle = '' ! case title - ! NB: This name must match the group name in namelist_definition.xml + ! NB: history_namelist value must match the group name in namelist_definition.xml character(len=*), parameter :: history_namelist = 'cam_history_nl' ! hrestpath: Full history restart pathnames character(len=cxx) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) @@ -44,26 +43,14 @@ module cam_history character(len=cxx) :: nhfil(pfiles) ! Array of current file names character(len=16) :: logname ! user name character(len=16) :: host ! host name +!!XXgoldyXX: Change inithist to use same values as any other history file character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or ! 'YEARLY' then write IC file +!!XXgoldyXX: Do we need maxvarmdims anymore? integer, private :: maxvarmdims = 1 ! - ! - ! Filename specifiers for history, initial files and restart history files - ! (%c = caseid, - ! %y = year, - ! %m = month, - ! %d = day, - ! %s = seconds in day, - ! %u = unit number (e.g., h0, i) - ! - ! rhfilename_spec is the templdate for history restart files - character(len=cxx) :: rhfilename_spec = '%c.cam.r%u.%y-%m-%d-%s.nc' - ! hfilename_spec is the template for each history file - character(len=cxx) :: hfilename_spec(pfiles) = (/ (' ', idx=1, pfiles) /) - integer :: lcltod_start(pfiles) ! start time of day for local time averaging (sec) integer :: lcltod_stop(pfiles) ! stop time of day for local time averaging, stop > start is wrap around (sec) From 7f3bb0b8b758b2bbf35a7f4e7ef19950abfdb31e Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Tue, 28 Mar 2023 18:31:01 +0200 Subject: [PATCH 08/79] Improvements to reading configuration and associated tests --- cime_config/hist_config.py | 165 +++++++++++++----- .../hist_config_files/atm_in_flat | 12 ++ .../hist_config_files/atm_in_multi | 2 + .../hist_config_files/user_nl_cam_flat | 5 + test/unit/test_hist_config.py | 8 +- 5 files changed, 143 insertions(+), 49 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index b7f97789..7a6dc1eb 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -25,12 +25,35 @@ from parse_tools import ParseObject, context_string, ParseInternalError # pylint: enable=wrong-import-position +## Default filename specifications for different history types +_DEFAULT_RESTART_HIST_SPEC = '%c.cam.r%u.%y-%m-%d-%s.nc' +_DEFAULT_HISTORY_SPEC = '%c.cam.%u.%y-%m-%d-%s.nc' + +# Note, these lists should match the corresponding lists in +# cam_hist_config_file.F90 +_TIME_PERIODS = ['nsteps', 'nstep', 'nseconds', 'nsecond', + 'nminutes', 'nminute', 'nhours', 'nhour', 'ndays', 'nday', + 'monthly', 'nmonths', 'nmonth', 'nyears', 'nyear', + 'steps', 'seconds', 'minutes', 'hours', + 'days', 'months', 'years'] +_OUT_PRECS = ['REAL32', 'REAL64'] + ############################################################################## ### -### Support functions for history configuration commands +### Support class and functions for history configuration commands ### ############################################################################## +############################################################################## +class HistoryConfigError(ValueError): +############################################################################## + """Error type specific to history configuration parsing""" + + def __init__(self, message): + """Initialize this exception""" + logging.shutdown() + super(HistoryConfigError, self).__init__(message) + ############################################################################## def blank_config_line(line): ############################################################################## @@ -156,11 +179,11 @@ def _is_mult_period(entry): # end if if good_entry: period = tokens[-1].lower() - if period in HistConfigEntry._TIME_PERIODS: + if period in _TIME_PERIODS: good_entry = (good_entry, period) else: good_entry = None - time_periods = ", ".join(HistConfigEntry._TIME_PERIODS) + time_periods = ", ".join(_TIME_PERIODS) errmsg = "period must be one of {}".format(time_periods) # end if # end if @@ -185,15 +208,15 @@ def _is_prec_str(entry): """ ustr = entry.strip().upper() errmsg = None - if ustr not in HistConfigEntry._OUT_PRECS: + if ustr not in _OUT_PRECS: ustr = None - out_precs = ", ".join(HistConfigEntry._OUT_PRECS) + out_precs = ", ".join(_OUT_PRECS) errmsg = "precision must be one of {}".format(out_precs) # end if return ustr, errmsg ############################################################################## -def _is_filename(entry): +def _is_string(entry): ############################################################################## """Return if it represents a valid history configuration filename or None if it is invalid. @@ -310,7 +333,7 @@ def output_nl_fieldlist(self, outfile, field_varname): A list is only output if there are members in the list """ if self.__field_names: - lhs = " {} = ".format(field_varname) + lhs = f" {field_varname} = " blank_lhs = ' '*(len(field_varname) + 5) # Break up output into lines num_fields = self.num_fields() @@ -335,8 +358,7 @@ def output_nl_fieldlist(self, outfile, field_varname): comma = "," if fld_end < num_fields - 1 else "" quotelist = ["'{}{}'".format(x, ' '*(self.max_len - len(x))) for x in self.__field_names[fld_beg:fld_end+1]] - outfile.write("{}{}{}\n".format(lhs, ", ".join(quotelist), - comma)) + outfile.write(f"{lhs}{', '.join(quotelist)}{comma}\n") lhs = blank_lhs # end while # end if @@ -376,16 +398,6 @@ def __str__(self): _NETCDF_ID_RE = re.compile(r"^[a-z][a-z0-9_]{0,62}$", re.IGNORECASE) -############################################################################## -class HistoryConfigError(ValueError): -############################################################################## - """Error type specific to history configuration parsing""" - - def __init__(self, message): - """Initialize this exception""" - logging.shutdown() - super(HistoryConfigError, self).__init__(message) - ############################################################################## class HistConfigEntry(): ############################################################################## @@ -396,16 +408,6 @@ class HistConfigEntry(): __HIST_CONF_ENTRY_RE = re.compile(r"[a-z][a-z_]*") __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:=][ ]*(.*)$" - # Note, these lists should match the corresponding lists in - # cam_hist_config_file.F90 - _TIME_PERIODS = ['nsteps', 'nstep', 'nseconds', 'nsecond', - 'nminutes', 'nminute', 'nhours', 'nhour', 'ndays', 'nday', - 'monthly', 'nmonths', 'nmonth', 'nyears', 'nyear', - 'steps', 'seconds', 'minutes', 'hours', - 'days', 'months', 'years'] - - _OUT_PRECS = ['REAL32', 'REAL64'] - def __init__(self, entry_string, entry_check_fn, process_fn): """Set the entry string regular expression and value check function for this history configuration entry type @@ -503,10 +505,12 @@ class HistoryVolConfig(): # Note, variable values below must match those in cam_hist_config_file.F90 # (without leading undescores) __UNSET_C = 'UNSET' + __HIST_FILE = "history" __SAT_FILE = "satellite" __INITIAL_FILE = "initial_value" + __HFILE_TYPES = [__HIST_FILE, __SAT_FILE, __INITIAL_FILE] - def __init__(self, volume, file_type="history"): + def __init__(self, volume): """Initialize a HistoryConfig object to a default state. is the history file descriptor (e.g., h1, i) """ @@ -521,6 +525,7 @@ def __init__(self, volume, file_type="history"): self.__min_fields, self.__max_fields, self.__var_fields] self.__precision = 'REAL32' + self.__precision_set = False if self.__volume == 'h0': self.__max_frames = 1 self.__output_freq = (1, 'month') @@ -528,7 +533,12 @@ def __init__(self, volume, file_type="history"): self.__max_frames = 30 self.__output_freq = (1, 'day') # end if - self.__file_type = file_type + self.__max_frames_set = False + self.__file_type = self.__HIST_FILE + self.__filename_spec = _DEFAULT_HISTORY_SPEC + self.__restart_fname_spec = _DEFAULT_RESTART_HIST_SPEC + self.__fname_spec_set = False + self.__restart_fname_spec_set = False self.__collect_patch_output = False self.__interp_out = False self.__interp_nlat = 0 @@ -645,8 +655,9 @@ def precision(self): def set_precision(self, prec, pobj, logger): """Modify the precision property of this HistoryVolConfig object. Return True if is a recognized precision""" - if prec in HistConfigEntry._OUT_PRECS: + if prec in _OUT_PRECS: self.__precision = prec + self.__precision_set = True if logger.getEffectiveLevel() <= logging.DEBUG: ctx = context_string(pobj) logger.debug("Setting precision to '{}'{}".format(prec, ctx)) @@ -670,6 +681,7 @@ def set_max_frames(self, nframes, pobj, logger): nframes_ok = nframes_i and (nframes > 0) if nframes_ok: self.__max_frames = nframes_i + self.__max_frames_set = True if logger.getEffectiveLevel() <= logging.DEBUG: ctx = context_string(pobj) logger.debug("Setting max frames to '{}'{}".format(nframes, @@ -703,7 +715,7 @@ def set_output_frequency(self, ofreq, pobj, logger): if ( isinstance(ofreq, tuple) and (len(ofreq) == 2) and isinstance(ofreq[0], int) and isinstance(ofreq[1], str) and (ofreq[0] > 0) and - (ofreq[1].strip() in HistConfigEntry._TIME_PERIODS)): + (ofreq[1].strip() in _TIME_PERIODS)): self.__output_freq = ofreq return True # end if @@ -718,13 +730,73 @@ def file_type(self): def set_file_type(self, ftype, pobj, logger): """Modify the file_type property of this HistoryVolConfig object""" - self.__file_type = ftype - if logger.getEffectiveLevel() <= logging.DEBUG: + if ftype in self.__HFILE_TYPES: + self.__file_type = ftype + else: + tstr = f", must be one of ({', '.join(self.__HFILE_TYPES)})." + raise HistoryConfigError(f"Bad history file type, '{ftype}'{tstr}") + # end if + if (ftype == self.__INITIAL_FILE) and (not self.__max_frames_set): + self.__max_frames = 1 + # end if + if (ftype == self.__INITIAL_FILE) and (not self.__precision_set): + self.__precision = 'REAL64' + # end if + if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): ctx = context_string(pobj) logger.debug("Setting file type to '{}'{}".format(ftype, ctx)) # end if return True + @property + def filename_spec(self): + """Return the filename_spec property for this HistoryVolConfig object""" + return self.__filename_spec + + def set_filename_spec(self, fnspec, pobj=None, logger=None): + """Modify the filename_spec property of this HistoryVolConfig object. + If the restart filename spec has not yet been set, set it to the default + for if possible (i.e., if contains a '%u'). + Note that it is an error to try and set this twice. + """ + self.__filename_spec = ftype + self.__fname_spec_set = True + if not self.__restart_fname_spec_set: + if '%u' in self.__filename_spec: + self.__restart_fname_spec = self.__filename_spec.replace("%u", + "r%u") + # end if + # end if + if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): + ctx = context_string(pobj) + logger.debug("Setting filename spec to '{}'{}".format(fnspec, ctx)) + # end if + return True + + @property + def restart_fname_spec(self): + """Return the restart history filename_spec property for this + HistoryVolConfig object""" + return self.__restart_fname_spec + + def set_restart_fname_spec(self, rfnspec=None, pobj=None, logger=None): + """Modify the filename_spec property of this HistoryVolConfig object. + If the restart filename spec has not yet been set, set it to the default + for if possible (i.e., if contains a '%u'). + Note that it is an error to try and set this twice. + """ + if not rfnspec: + rfnspec = self.__filename_spec.replace("%u", "r%u") + # end if + self.__restart_fname_spec = rfnspec + self.__restart_fname_spec_set = True + if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): + ctx = context_string(pobj) + logger.debug("Setting restart filename spec to '{}'{}".format(fnspec, + ctx)) + # end if + return True + def num_fields(self, fld_type): """Return the number of fields for field list type, .""" num_flds = 0 @@ -747,16 +819,17 @@ def output_config_namelist(self, outfile): """Write the fortran namelist object for this HistoryVolConfig object""" outfile.write("\n&hist_file_config_nl\n") - outfile.write(" hist_volume = '{}'\n".format(self.volume)) + outfile.write(f" hist_volume = '{self.volume}'\n") self.__inst_fields.output_nl_fieldlist(outfile, "hist_inst_fields") self.__avg_fields.output_nl_fieldlist(outfile, "hist_avg_fields") self.__min_fields.output_nl_fieldlist(outfile, "hist_min_fields") self.__max_fields.output_nl_fieldlist(outfile, "hist_max_fields") self.__var_fields.output_nl_fieldlist(outfile, "hist_var_fields") - outfile.write(" hist_max_frames = {}\n".format(self.__max_frames)) - outfile.write(" hist_output_frequency = '{}'\n".format(self.outfreq_str())) - outfile.write(" hist_precision = '{}'\n".format(self.__precision)) - outfile.write(" hist_file_type = '{}'\n".format(self.__file_type)) + outfile.write(f" hist_max_frames = {self.__max_frames}\n") + outfile.write(f" hist_output_frequency = '{self.outfreq_str()}'\n") + outfile.write(f" hist_precision = '{self.__precision}'\n") + outfile.write(f" hist_file_type = '{self.__file_type}'\n") + outfile.write(f" hist_filename_spec = '{self.__filename_spec}'\n") outfile.write("/\n") ############################################################################## @@ -778,6 +851,8 @@ def output_config_namelist(self, outfile): HistConfigEntry(r"hist_add_var_fields", _list_of_idents, HistoryVolConfig.add_var_fields), + HistConfigEntry(r"hist_file_type", _is_string, + HistoryVolConfig.set_file_type), HistConfigEntry(r"hist_max_frames", _is_integer, HistoryVolConfig.set_max_frames), HistConfigEntry(r"hist_output_frequency", @@ -785,10 +860,10 @@ def output_config_namelist(self, outfile): HistoryVolConfig.set_output_frequency), HistConfigEntry(r"hist_precision", _is_prec_str, HistoryVolConfig.set_precision), - HistConfigEntry(r"hist_diag_file", _is_filename, + HistConfigEntry(r"hist_diag_file", _is_string, None), - HistConfigEntry(r"hist_filename_template", - _is_filename, None), + HistConfigEntry(r"hist_filename_template", _is_string, + HistoryVolConfig.set_filename_spec), HistConfigEntry(r"hist_remove_fields", _list_of_idents, HistoryVolConfig.remove_fields)] @@ -945,8 +1020,8 @@ def parse_hist_config_file(self, filename, logger, volume=None): self.parse_hist_config_file(dfile, logger, volume=fnum) else: ctx = context_string(pobj) - emsg = "History config file, '{}', not found{}" - raise HistoryConfigError(emsg.format(cmd_val, ctx)) + emsg = f"History config file, '{cmd_val}', not found{ctx}" + raise HistoryConfigError(emsg) # end if else: hconf_entry = _HIST_CONFIG_ENTRY_OBJS[cmd] diff --git a/test/unit/sample_files/hist_config_files/atm_in_flat b/test/unit/sample_files/hist_config_files/atm_in_flat index ae0caee9..225968bd 100644 --- a/test/unit/sample_files/hist_config_files/atm_in_flat +++ b/test/unit/sample_files/hist_config_files/atm_in_flat @@ -17,6 +17,7 @@ hist_output_frequency = '14*hours' hist_precision = 'REAL32' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / &hist_file_config_nl @@ -26,4 +27,15 @@ hist_output_frequency = '2*nsteps' hist_precision = 'REAL64' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' +/ + +&hist_file_config_nl + hist_volume = 'i' + hist_inst_fields = 'X' + hist_max_frames = 1 + hist_output_frequency = '2*nmonths' + hist_precision = 'REAL64' + hist_file_type = 'initial_value' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / diff --git a/test/unit/sample_files/hist_config_files/atm_in_multi b/test/unit/sample_files/hist_config_files/atm_in_multi index 3b5cb58c..b62173d6 100644 --- a/test/unit/sample_files/hist_config_files/atm_in_multi +++ b/test/unit/sample_files/hist_config_files/atm_in_multi @@ -56,6 +56,7 @@ hist_output_frequency = '1*monthly' hist_precision = 'REAL32' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / &hist_file_config_nl @@ -65,4 +66,5 @@ hist_output_frequency = '2*nsteps' hist_precision = 'REAL64' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / diff --git a/test/unit/sample_files/hist_config_files/user_nl_cam_flat b/test/unit/sample_files/hist_config_files/user_nl_cam_flat index 0116732a..a03e0c60 100644 --- a/test/unit/sample_files/hist_config_files/user_nl_cam_flat +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_flat @@ -16,3 +16,8 @@ hist_add_inst_fields;h3: T, U, V hist_output_frequency;h3: 2*nsteps hist_precision;h3: REAL64 hist_max_frames;h3: 24 + +! Let's try an initial data file +hist_add_inst_fields;i: X +hist_output_frequency;i: 2*nmonths +hist_file_type;i = initial_value diff --git a/test/unit/test_hist_config.py b/test/unit/test_hist_config.py index 2ca30dfc..5f4856ec 100644 --- a/test/unit/test_hist_config.py +++ b/test/unit/test_hist_config.py @@ -101,8 +101,8 @@ def test_flat_user_nl_cam(self): amsg = "Test failure: no HistConfig object created" self.assertTrue(isinstance(hist_configs, HistoryConfig), msg=amsg) clen = len(hist_configs) - amsg = "Test failure: Found {} history files, expected 2".format(clen) - self.assertEqual(clen, 2, msg=amsg) + amsg = "Test failure: Found {} history files, expected 3".format(clen) + self.assertEqual(clen, 3, msg=amsg) # Check properties of created config objects self.assertTrue('h1' in hist_configs, msg="'h1' not in hist_configs") hconfig = hist_configs['h1'] @@ -121,7 +121,7 @@ def test_flat_user_nl_cam(self): amsg = "{} does not exist".format(out_source) self.assertTrue(os.path.exists(out_source), msg=amsg) # Make sure the output file is correct - amsg = "{} does not match {}".format(out_test, out_source) + amsg = "{} does not match {}".format(out_source, out_test) self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), msg=amsg) @@ -161,7 +161,7 @@ def test_multi_user_nl_cam(self): amsg = "{} does not exist".format(out_source) self.assertTrue(os.path.exists(out_source), msg=amsg) # Make sure the output file is correct - amsg = "{} does not match {}".format(out_test, out_source) + amsg = "{} does not match {}".format(out_source, out_test) self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), msg=amsg) From bbd2c4bc8ad98ef87cd74e73a4ce5fefe42a84b2 Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Fri, 31 Mar 2023 18:32:25 +0200 Subject: [PATCH 09/79] Resurrect Fortran history tests. Add ability to use real endrun for debugging --- cime_config/hist_config.py | 10 + src/control/cam_control_mod.F90 | 4 +- src/history/cam_hist_file.F90 | 93 +++++----- src/history/cam_history.F90 | 93 ---------- src/utils/cam_abortutils.F90 | 174 ++---------------- src/utils/cam_field_read.F90 | 101 +++++----- src/utils/cam_filenames.F90 | 82 +++++++-- src/utils/cam_pio_utils.F90 | 12 +- test/hist_tests/CMakeLists.txt | 10 +- test/hist_tests/run_test | 10 +- .../sample_files/single_good_config.nl | 1 + .../sample_files/two_good_configs.nl | 2 + .../sample_files/user_nl_cam_defaults | 17 ++ test/hist_tests/test_history.F90 | 17 +- test/include/cam_control_mod.F90 | 4 +- test/include/shr_mem_mod.F90 | 63 +++++++ test/include/shr_string_mod.F90 | 70 ------- 17 files changed, 299 insertions(+), 464 deletions(-) create mode 100644 test/hist_tests/sample_files/user_nl_cam_defaults create mode 100644 test/include/shr_mem_mod.F90 diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 7a6dc1eb..f26b04ff 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -26,7 +26,17 @@ # pylint: enable=wrong-import-position ## Default filename specifications for different history types +# Filename specifiers for history, initial files and restart history files +# %c = caseid, +# %y = year, +# %m = month, +# %d = day, +# %s = seconds in day, +# %u = unit number (e.g., h0, i) +# +# rhfilename_spec is the templdate for history restart files _DEFAULT_RESTART_HIST_SPEC = '%c.cam.r%u.%y-%m-%d-%s.nc' +# hfilename_spec is the template for each history file _DEFAULT_HISTORY_SPEC = '%c.cam.%u.%y-%m-%d-%s.nc' # Note, these lists should match the corresponding lists in diff --git a/src/control/cam_control_mod.F90 b/src/control/cam_control_mod.F90 index 91254667..f87852e3 100644 --- a/src/control/cam_control_mod.F90 +++ b/src/control/cam_control_mod.F90 @@ -21,8 +21,8 @@ module cam_control_mod ! cam_ctrl_set_orbit ! cam_ctrl_set_physics_type - character(len=cl), protected :: caseid ! case ID - character(len=cl), protected :: ctitle ! case title + character(len=cl), protected :: caseid = '' ! case ID + character(len=cl), protected :: ctitle = '' ! case title logical, protected :: initial_run ! startup mode which only requires a minimal initial file logical, protected :: restart_run ! continue a previous run; requires a restart file diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index bf673cac..78cce5a2 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -39,7 +39,7 @@ module cam_hist_file integer, private :: max_frames = UNSET_I integer, private :: output_freq_mult = UNSET_I character(len=8), private :: output_freq_type = UNSET_C - character(len=*), allocatable, private :: filename_spec + character(len=:), allocatable, private :: filename_spec integer, private :: hfile_type = hfile_type_default logical, private :: collect_patch_output = PATCH_DEF type(interp_info_t), pointer, private :: interp_info => NULL() @@ -65,31 +65,18 @@ module cam_hist_file private :: read_namelist_entry ! Read a namelist group and create config CONTAINS - ! - ! Filename specifiers for history, initial files and restart history files - ! %c = caseid, - ! %y = year, - ! %m = month, - ! %d = day, - ! %s = seconds in day, - ! %u = unit number (e.g., h0, i) - ! - ! rhfilename_spec is the templdate for history restart files - character(len=*), parameter :: rhfilename_spec = '%c.cam.r%u.%y-%m-%d-%s.nc' - ! hfilename_spec is the template for each history file - character(len=*), parameter :: hfilename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' ! ======================================================================== - function config_filename(this, inst_suffix) result(cfile) + function config_filename(this) result(cfile) use shr_kind_mod, only: CL => SHR_KIND_CL use cam_filenames, only: interpret_filename_spec ! Dummy arguments class(hist_file_t), intent(in) :: this - character(len=*), intent(in) :: inst_suffix character(len=CL) :: cfile - cfile = interpret_filename_spec(this%filename_spec, unit=this%volume) + cfile = interpret_filename_spec(this%filename_spec, unit=this%volume, & + incomplete_ok=.true.) end function config_filename @@ -153,7 +140,7 @@ logical function config_history_file(this) ! Dummy argument class(hist_file_t), intent(in) :: this - config_init_value_file = this%hfile_type == hfile_type_history + config_history_file = this%hfile_type == hfile_type_history end function config_history_file @@ -183,7 +170,7 @@ logical function config_restart_file(this) ! Dummy argument class(hist_file_t), intent(in) :: this - config_satellite_file = this%hfile_type == hfile_type_restart + config_restart_file = this%hfile_type == hfile_type_restart end function config_restart_file @@ -198,8 +185,7 @@ subroutine config_reset(this) this%max_frames = UNSET_I this%output_freq_mult = UNSET_I this%output_freq_type = UNSET_C - this%is_init_val_file = .false. - this%is_sat_track_file = .false. + this%hfile_type = hfile_type_default if (associated(this%interp_info)) then call this%interp_info%reset() deallocate(this%interp_info) @@ -210,7 +196,7 @@ end subroutine config_reset ! ======================================================================== subroutine config_configure(this, volume, out_prec, max_frames, & - output_freq, file_type, collect_patch_out, filename_spec, & + output_freq, file_type, filename_spec, collect_patch_out, & interp_out, interp_nlat, interp_nlon, interp_grid, interp_type) use shr_kind_mod, only: CL=>SHR_KIND_CL use shr_string_mod, only: to_lower => shr_string_toLower @@ -223,8 +209,8 @@ subroutine config_configure(this, volume, out_prec, max_frames, & integer, intent(in) :: max_frames character(len=*), intent(in) :: output_freq integer, intent(in) :: file_type + character(len=*), intent(in) :: filename_spec logical, intent(in) :: collect_patch_out - character(len*), intent(in) :: filename_spec logical, optional, intent(in) :: interp_out integer, optional, intent(in) :: interp_nlat integer, optional, intent(in) :: interp_nlon @@ -274,20 +260,29 @@ end subroutine config_configure ! ======================================================================== subroutine config_print_config(this) - use spmd_utils, only: masterproc - use cam_logfile, only: iulog + use string_utils, only: to_str + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use cam_logfile, only: iulog ! Dummy argument class(hist_file_t), intent(in) :: this if (masterproc) then write(iulog, '(2a)') "History configuration for volume = ", & trim(this%volume) - if (this%is_init_val_file) then - write(6, '(a)') " File will contain initial values" - end if - if (this%is_sat_track_file) then - write(6, '(a)') " File will contain satellite track values" - end if + select case(this%hfile_type) + case (hfile_type_history) + write(iulog, *) "File will contain model history (diagnostics) output" + case (hfile_type_init_value) + write(iulog, *) "File will contain values for model initialization" + case (hfile_type_sat_track) + write(iulog, *) "File will contain satellite track values" + case (hfile_type_restart) + write(iulog, *) "File contains history restart information" + case default + call endrun("ERROR: Unknown CAM history file type, "// & + to_str(this%hfile_type)) + end select if (this%rl_kind == REAL64) then write(iulog, '(a)') " Ouput precision, 64 bits" else if (this%rl_kind == REAL32) then @@ -295,20 +290,20 @@ subroutine config_print_config(this) else write(iulog, '(a,i0)') " Unknown output precision, ", this%rl_kind end if - write(6, '(a,i0)') " Maximum number of output frames per file = ", & + write(iulog, '(a,i0)') " Maximum number of output frames per file = ", & this%max_frames if (this%output_freq_mult == 1) then - write(6, *) " Writing output once per ", trim(this%output_freq_type) + write(iulog, *) " Writing output once per ", trim(this%output_freq_type) else - write(6, '(a,i0,3a)') " Writing output every ", & + write(iulog, '(a,i0,3a)') " Writing output every ", & this%output_freq_mult, " ", trim(this%output_freq_type), "s" end if !!XXgoldyXX: Fix this when patch output is known if (this%collect_patch_output) then - write(6, '(2a)') " Output from all patches will be collected ", & + write(iulog, '(2a)') " Output from all patches will be collected ", & "into a single variable" else - write(6, '(2a)') " Output from each patch will be written ", & + write(iulog, '(2a)') " Output from each patch will be written ", & "as a separate variable" end if if (associated(this%interp_info)) then @@ -342,7 +337,6 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & use mpi, only: MPI_CHARACTER, MPI_INTEGER, MPI_LOGICAL use shr_kind_mod, only: CL=>SHR_KIND_CL use string_utils, only: to_str - use cam_logfile, only: iulog use cam_abortutils, only: endrun use spmd_utils, only: masterproc, masterprocid, mpicom ! Read a history file configuration from and process it into @@ -483,10 +477,10 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & masterprocid, mpicom, ierr) ! Configure the history file call hfile_config%configure(hist_volume, rl_kind, hist_max_frames, & - hist_output_frequency, file_type, & - hist_collect_patch_output, hist_interp_out, hist_interp_nlat, & - hist_interp_nlon, hist_interp_grid, hist_interp_type, & - hist_filename_spec) + hist_output_frequency, file_type, hist_filename_spec, & + hist_collect_patch_output, interp_out=hist_interp_out, & + interp_nlat=hist_interp_nlat, interp_nlon=hist_interp_nlon, & + interp_grid=hist_interp_grid, interp_type=hist_interp_type) call hfile_config%print_config() end subroutine read_namelist_entry @@ -500,6 +494,7 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & use shr_nl_mod, only: shr_nl_find_group_name use cam_abortutils, only: endrun use string_utils, only: to_str + use cam_logfile, only: iulog use spmd_utils, only: mpicom, masterproc, masterprocid use cam_abortutils, only: endrun, check_allocate ! Read the maximum sizes of field arrays from namelist file and allocate @@ -552,13 +547,13 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & if (ierr == 0) then read(unitn, hist_config_arrays_nl, iostat=ierr) if (ierr /= 0) then - write(errmsg, '(2a,i0,a)') subname, ": ERROR ", ierr, & + write(errmsg, '(2a,i0,a)') subname, ": ERROR ", ierr, & " reading namelist, hist_config_arrays_nl" call endrun(trim(errmsg)) return ! For testing end if else - write(6, *) subname, ": WARNING, no hist_config_arrays_nl ", & + write(iulog, *) subname, ": WARNING, no hist_config_arrays_nl ", & "namelist found" end if end if @@ -575,19 +570,19 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & mpicom, ierr) ! Allocate arrays allocate(hist_inst_fields(hist_num_inst_fields), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'hist_inst_fields', errmsg=errmsg, & + call check_allocate(ierr, subname, 'hist_inst_fields', & file=__FILE__, line=__LINE__-1) allocate(hist_avg_fields(hist_num_avg_fields), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'hist_avg_fields', errmsg=errmsg, & + call check_allocate(ierr, subname, 'hist_avg_fields', & file=__FILE__, line=__LINE__-1) allocate(hist_min_fields(hist_num_min_fields), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'hist_min_fields', errmsg=errmsg, & + call check_allocate(ierr, subname, 'hist_min_fields', & file=__FILE__, line=__LINE__-1) allocate(hist_max_fields(hist_num_max_fields), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'hist_max_fields', errmsg=errmsg, & + call check_allocate(ierr, subname, 'hist_max_fields', & file=__FILE__, line=__LINE__-1) allocate(hist_var_fields(hist_num_var_fields), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'hist_var_fields', errmsg=errmsg, & + call check_allocate(ierr, subname, 'hist_var_fields', & file=__FILE__, line=__LINE__-1) end subroutine allocate_field_arrays @@ -692,7 +687,7 @@ function hist_read_namelist_config(filename) result(config_arr) return ! Needed for testing end if allocate(config_arr(num_configs), stat=ierr, errmsg=errmsg) - call check_allocate(ierr, subname, 'config_arr', errmsg=errmsg, & + call check_allocate(ierr, subname, 'config_arr', & file=__FILE__, line=__LINE__-2) ! This block is needed for testing if (ierr /= 0) then diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 6e8127be..cf485f64 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -95,99 +95,6 @@ subroutine history_readnl(nlfile) err_cnt = err_cnt + 1 end if ! - ! Initialize the filename specifier if not already set - ! This is the format for the history filenames: - ! %c= caseid, %t=file no., %y=year, %m=month, %d=day, %s=second, %%=% - ! See the filenames module for more information - ! - do t = 1, pfiles - if ( len_trim(hfilename_spec(fil_idx)) == 0 )then - if ( hist_freq(fil_idx) == 0 )then - ! Monthly files - hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // & - '.%u.%y-%m.nc' - else - hfilename_spec(fil_idx) = '%c.cam' // trim(inst_suffix) // & - '.%u.%y-%m-%d-%s.nc' - end if - end if - ! - - ! Print per-file averaging flags - if (masterproc) then - do t = 1, pfiles - if (avgflag_perfile(fil_idx) /= ' ') then - write(iulog, *) 'Unless overridden by namelist input on a per-field basis (FINCL),' - write(iulog,*) 'All fields on history file ',t,' will have averaging flag ',avgflag_perfile(fil_idx) - end if - ! Enforce no interpolation for satellite files - if (is_satfile(fil_idx) .and. interpolate_output(fil_idx)) then - write(iulog, *) 'WARNING: Interpolated output not supported for a satellite history file, ignored' - interpolate_output(fil_idx) = .false. - end if - ! Enforce no interpolation for IC files - if (is_initfile(fil_idx) .and. interpolate_output(fil_idx)) then - write(iulog, *) 'WARNING: Interpolated output not supported for an initial data (IC) history file, ignored' - interpolate_output(fil_idx) = .false. - end if - end do - end if - - ! Write out inithist info - if (masterproc) then - if (inithist == '6-HOURLY' ) then - write(iulog,*)'Initial conditions history files will be written 6-hourly.' - else if (inithist == 'DAILY' ) then - write(iulog,*)'Initial conditions history files will be written daily.' - else if (inithist == 'MONTHLY' ) then - write(iulog,*)'Initial conditions history files will be written monthly.' - else if (inithist == 'YEARLY' ) then - write(iulog,*)'Initial conditions history files will be written yearly.' - else if (inithist == 'CAMIOP' ) then - write(iulog,*)'Initial conditions history files will be written for IOP.' - else if (inithist == 'ENDOFRUN' ) then - write(iulog,*)'Initial conditions history files will be written at end of run.' - else - write(iulog,*)'Initial conditions history files will not be created' - end if - end if - - ! Print out column-output information - do t = 1, size(fincllonlat, 2) - if (ANY(len_trim(fincllonlat(:,t)) > 0)) then - if (collect_column_output(fil_idx)) then - write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, columns will be collected into ncol dimension' - else - write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, patches will be written to individual variables' - end if - end if - end do - - ! Broadcast namelist variables - call mpi_bcast(ndens, pfiles, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(hist_freq, pfiles, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(mfilt, pfiles, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(inithist,len(inithist), mpi_character, masterprocid, mpicom, ierr) - call mpi_bcast(inithist_all,1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast(lcltod_start, pfiles, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(lcltod_stop, pfiles, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(collect_column_output, pfiles, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast(empty_hfiles,1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast(avgflag_perfile, pfiles, mpi_character, masterprocid, mpicom, ierr) - call mpi_bcast(hfilename_spec, len(hfilename_spec(1))*pfiles, mpi_character, masterprocid, mpicom, ierr) - call mpi_bcast(fincl, len(fincl (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) - call mpi_bcast(fexcl, len(fexcl (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) - - call mpi_bcast(fincllonlat, len(fincllonlat (1,1))*pflds*pfiles, mpi_character, masterprocid, mpicom, ierr) - - call mpi_bcast(fout_prec, len(fout_prec(1,1))*pflds*pfiles, & - mpi_character, masterprocid, mpicom, ierr) - t = size(interpolate_nlat, 1) - call mpi_bcast(interpolate_nlat, t, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(interpolate_nlon, t, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(interpolate_gridtype, t, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(interpolate_type, t, mpi_integer, masterprocid, mpicom, ierr) - call mpi_bcast(interpolate_output, pfiles, mpi_logical, masterprocid, mpicom, ierr) ! Setup the interpolate_info structures do t = 1, size(interpolate_info) diff --git a/src/utils/cam_abortutils.F90 b/src/utils/cam_abortutils.F90 index 01bc3a9b..5b0aace7 100644 --- a/src/utils/cam_abortutils.F90 +++ b/src/utils/cam_abortutils.F90 @@ -1,7 +1,7 @@ module cam_abortutils use shr_sys_mod, only: shr_sys_abort, shr_sys_flush - use shr_kind_mod, only: max_chars=>shr_kind_cl, msg_len=>SHR_KIND_CS + use shr_kind_mod, only: max_chars=>shr_kind_cx, msg_len=>SHR_KIND_CS use shr_kind_mod, only: r8 => shr_kind_r8 use shr_mem_mod, only: shr_mem_getusage use pio, only: file_desc_t @@ -12,20 +12,8 @@ module cam_abortutils save public :: endrun - public :: safe_endrun public :: check_allocate - public :: cam_register_open_file - public :: cam_register_close_file - - type :: open_file_pointer - type(file_desc_t), pointer :: file_desc => NULL() - character(len=max_chars) :: file_name = '' - type(open_file_pointer), pointer :: next => NULL() - end type open_file_pointer - - type(open_file_pointer), pointer :: open_files_head => NULL() - type(open_file_pointer), pointer :: open_files_tail => NULL() - type(open_file_pointer), pointer :: open_files_pool => NULL() + public :: check_endrun ! Stub needed for testing CONTAINS @@ -47,10 +35,10 @@ subroutine check_allocate(errcode, subname, fieldname, file, line) call shr_mem_getusage(mem_hw_val, mem_val) ! Write error message with memory stats - write(abort_msg, '(4a,i0,a,f10.2,a,f10.2,a)') & - trim(subname), ": Allocate of '", & - trim(fieldname), "' failed with code ", errcode, & - ". Memory highwater is ", mem_hw_val, & + write(abort_msg, '(4a,i0,a,f10.2,a,f10.2,a)') & + trim(subname), ": Allocate of '", & + trim(fieldname), "' failed with code ", errcode, & + ". Memory highwater is ", mem_hw_val, & " mb, current memory usage is ", mem_val, " mb" ! End the simulation @@ -59,110 +47,6 @@ subroutine check_allocate(errcode, subname, fieldname, file, line) end subroutine check_allocate - subroutine cam_register_open_file(file, file_name) - ! Dummy arguments - type(file_desc_t), target, intent(in) :: file - character(len=*), intent(in) :: file_name - ! Local variables - type(open_file_pointer), pointer :: of_ptr - type(open_file_pointer), pointer :: of_new - character(len=*), parameter :: subname = 'cam_register_open_file' - - nullify(of_new) - ! First, make sure we do not have this file - of_ptr => open_files_head - do while (associated(of_ptr)) - if (file%fh == of_ptr%file_desc%fh) then - call endrun(subname//': Cannot register '//trim(file_name)//', file already open as '//trim(of_ptr%file_name)) - end if - of_ptr => of_ptr%next - end do - ! If we get here, go ahead and register the file - if (associated(open_files_pool)) then - of_new => open_files_pool - of_new%file_desc = file - of_new%file_name = file_name - allocate(open_files_pool%next) - open_files_pool%next => open_files_pool - else - allocate(of_new) - allocate(of_new%file_desc) - of_new%file_desc = file - of_new%file_name = file_name - open_files_pool => of_new - end if - open_files_tail => of_new - if (.not. associated(open_files_head)) then - open_files_head => of_new - end if - end subroutine cam_register_open_file - - subroutine cam_register_close_file(file, log_shutdown_in) - ! Dummy arguments - type(file_desc_t), target, intent(in) :: file - character(len=*), optional, intent(in) :: log_shutdown_in - ! Local variables - type(open_file_pointer), pointer :: of_ptr - type(open_file_pointer), pointer :: of_prev - character(len=msg_len) :: log_shutdown - character(len=*), parameter :: subname = 'cam_register_close_file' - logical :: file_loop_var - - nullify(of_prev) - ! Are we going to log shutdown events? - if (present(log_shutdown_in)) then - log_shutdown = trim(log_shutdown_in) - else - log_shutdown = '' - end if - ! Look to see if we have this file - of_ptr => open_files_head - - !Set while-loop control variable - file_loop_var = .false. - if (associated(of_ptr)) then - if(associated(of_ptr%file_desc)) then - file_loop_var = .true. - end if - end if - - do while (file_loop_var) - if (file%fh == of_ptr%file_desc%fh) then - ! Remove this file from the list - if (associated(of_prev)) then - of_prev%next => of_ptr%next - else - open_files_head => of_ptr%next - end if - ! Log closure? - ! Note, no masterproc control because this could be any PE - if (len_trim(log_shutdown) > 0) then - write(iulog, '(a,": ",a," of ",a)') subname, & - trim(log_shutdown), trim(of_ptr%file_name) - call shr_sys_flush(iulog) - end if - ! Push this object on to free pool - nullify(of_ptr%file_desc) - of_ptr%next => open_files_pool - open_files_pool => of_ptr - nullify(of_ptr) - exit - else - of_prev => of_ptr - of_ptr => of_ptr%next - end if - !Check if loop needs to continue - if (.not.associated(of_ptr)) then - file_loop_var = .false. - else - if(.not.associated(of_ptr%file_desc)) then - file_loop_var = .false. - end if - end if - - end do - end subroutine cam_register_close_file - subroutine endrun(message, file, line) ! Parallel emergency stop ! Dummy arguments @@ -184,44 +68,14 @@ subroutine endrun(message, file, line) end subroutine endrun - subroutine safe_endrun(message, file, line) - ! Sequential/global emergency stop - use pio, only : pio_closefile - ! Dummy arguments - character(len=*), intent(in) :: message - character(len=*), optional, intent(in) :: file - integer, optional, intent(in) :: line + logical function check_endrun(test_desc, output) + character(len=*), optional, intent(in) :: test_desc + integer, optional, intent(in) :: output - ! Local variables - character(len=max_chars) :: abort_msg - type(open_file_pointer), pointer :: of_ptr - logical :: keep_loop - - ! First, close all open PIO files - of_ptr => open_files_head - - !Check if needed pointers are associated: - keep_loop = .false. - if (associated(of_ptr)) then - if (associated(of_ptr%file_desc)) then - keep_loop = .true. - end if - end if + ! Return .true. if an endrun message has been created + ! Stub, always return .false. + check_endrun = .false. + + end function check_endrun - do while (keep_loop) - call pio_closefile(of_ptr%file_desc) - call cam_register_close_file(of_ptr%file_desc, & - log_shutdown_in="Emergency close") - of_ptr => of_ptr%next - !End loop if new pointers aren't associated: - if (.not. associated(of_ptr)) then - keep_loop = .false. - else if (.not. associated(of_ptr%file_desc)) then - keep_loop = .false. - end if - end do - - call endrun(message, file, line) - - end subroutine safe_endrun end module cam_abortutils diff --git a/src/utils/cam_field_read.F90 b/src/utils/cam_field_read.F90 index 828d4698..32f51305 100644 --- a/src/utils/cam_field_read.F90 +++ b/src/utils/cam_field_read.F90 @@ -14,7 +14,7 @@ module cam_field_read use pio, only: pio_max_var_dims, io_desc_t use pio, only: pio_double, pio_setframe use spmd_utils, only: masterproc - use cam_abortutils, only: safe_endrun + use cam_abortutils, only: endrun use cam_logfile, only: iulog, debug_output, DEBUGOUT_INFO, DEBUGOUT_DEBUG !!XXgoldyXX: v support SCAM? ! use shr_scam_mod, only: shr_scam_getCloseLatLon ! Standardized system subroutines @@ -62,7 +62,7 @@ subroutine get_grid_diminfo(grid_name, grid_id, dim1name, dim2name, & grid_id = cam_grid_id(trim(grid_name)) if (.not. cam_grid_check(grid_id)) then - call safe_endrun(subname//': Internal error, no "'//grid_name//'" grid') + call endrun(subname//': Internal error, no "'//grid_name//'" grid') end if call cam_grid_get_dim_names(grid_id, dim1name, dim2name) call cam_grid_get_array_bounds(grid_id, dim_bounds) @@ -101,17 +101,17 @@ subroutine print_input_field_info(dimlens, ndims, min_ndims, max_ndims, & character(len=8) :: syntax(9) if (ndims < max(min_ndims, 1)) then - call safe_endrun(subname//': too few dimensions for '//trim(varname)) + call endrun(subname//': too few dimensions for '//trim(varname)) else if (ndims > max_ndims) then write(errormsg, '(3a,i0)') ': too many dimensions for, ', & trim(varname), ', ', ndims - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) else if (num_bounds < 1) then - call safe_endrun(subname//': too few dimension boundss for '//trim(varname)) + call endrun(subname//': too few dimension boundss for '//trim(varname)) else if (num_bounds > 3) then write(errormsg, '(3a,i0)') ': too many dimension bounds for, ', & trim(varname), ', ', num_bounds - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) else if (debug_output >= DEBUGOUT_DEBUG) then num_vals = 0 do ind = 1, num_bounds @@ -170,7 +170,7 @@ integer function num_target_dims(num_field_dims, unstruct) num_target_dims = num_target_dims - 1 end if if (num_target_dims < 1) then - call safe_endrun('num_target_dims, bad inputs') + call endrun('num_target_dims, bad inputs') end if end function num_target_dims @@ -250,10 +250,10 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & dim_bounds(:,1) = 0 dim_bounds(:,2) = -1 if (present(gridname)) then - call get_grid_diminfo(trim(gridname), grid_id, dim1name, dim2name, & + call get_grid_diminfo(trim(gridname), grid_id, dim1name, dim2name, & dim_bounds) else - call get_grid_diminfo('physgrid', grid_id, dim1name, dim2name, & + call get_grid_diminfo('physgrid', grid_id, dim1name, dim2name, & dim_bounds) end if @@ -270,7 +270,7 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & ! Is this an unstructured grid (i.e., one column dimension on file)? unstruct = cam_grid_is_unstructured(grid_id) if (block_indexed) then - call safe_endrun(subname//': Block indexed 1D field is invalid') + call endrun(subname//': Block indexed 1D field is invalid') else target_ndims = num_target_dims(2, unstruct) end if @@ -305,21 +305,21 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & varname, subname) ! Check to make sure that any 'extra' dimension is time if (ndims > target_ndims + 1) then - call safe_endrun(subname//': too many dimensions for '//trim(varname)) + call endrun(subname//': too many dimensions for '//trim(varname)) else if (ndims == target_ndims + 1) then ierr = pio_inq_dimname(ncid, dimids(ndims), tmpname) if (trim(tmpname) /= 'time') then - call safe_endrun(subname//': dimension mismatch for '//trim(varname)) + call endrun(subname//': dimension mismatch for '//trim(varname)) end if if (present(timelevel)) then if (timelevel > dimlens(ndims)) then write(errormsg, '(a,i0,a,i0)') ': timelevel, ', timelevel, & ', exceeds file limit, ', dimlens(ndims) - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if end if else if (ndims < target_ndims) then - call safe_endrun(subname//': too few dimensions for '//trim(varname)) + call endrun(subname//': too few dimensions for '//trim(varname)) end if ! No else, things are okay ! ! Get array dimension id's and sizes @@ -328,7 +328,7 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & if (arraydimsize(1) /= size(field, 1)) then write(errormsg, '(4a,i0)') ': Mismatch between array bounds ', & 'and field size for ', trim(varname), ', dimension ', 1 - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if ! Check that the number of columns in the file matches the number of @@ -339,7 +339,7 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & trim(varname), ', file = ', dimlens(1), ', grid = ', & grid_dimlens(1), ' * ', grid_dimlens(2), ' = ', & (grid_dimlens(1) * grid_dimlens(2)) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if else do jndex = 1, target_ndims @@ -347,7 +347,7 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & write(errormsg, '(a,i0,2a,2(a,i0))') ': Dim ', jndex, & ' mismatch for ', trim(varname), ', file = ', & dimlens(jndex), 'grid = ', grid_dimlens(jndex) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if end do end if @@ -365,9 +365,9 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & if (single_column) then if (unstruct) then ! Clearly, this will not work for an unstructured dycore - call safe_endrun(subname//': SCAM not supported in this configuration') + call endrun(subname//': SCAM not supported in this configuration') else - call safe_endrun(subname//': SCAM support not implemented') + call endrun(subname//': SCAM support not implemented') end if else ! All distributed array processing @@ -381,13 +381,14 @@ subroutine infld_real8_1d(varname, ncid, field, readvar, gridname, & ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) !End run if PIO error occurred: if (ierr /= PIO_NOERR) then - write(errormsg, *) subname//': cam_pio_inq_var_fill failed with PIO error: ', ierr - call safe_endrun(errormsg) + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr + call endrun(errormsg) end if end if if (masterproc .and. log_read_field) then - write(iulog,*) subname//': read field '//trim(varname) + write(iulog,*) subname, ': read field ', trim(varname) end if end if ! end of readvar_tmp @@ -523,9 +524,9 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & ! If is a 3D quantity, fix up its dimensions if ((dim_bounds(2,2) <= 0) .or. (dim_bounds(2,2) < dim_bounds(2,1))) then if (.not. present(dim3name)) then - call safe_endrun(subname//': dim3name must be present for 3D field') + call endrun(subname//': dim3name must be present for 3D field') else if (.not. present(dim3_bnds)) then - call safe_endrun(subname//': dim3_bnds must be present for 3D field') + call endrun(subname//': dim3_bnds must be present for 3D field') end if dim_bounds(2,:) = dim3_bnds(:) dim2name = trim(dim3name) @@ -545,22 +546,22 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & pdims = ndims ! Check to make sure that any 'extra' dimension is time if (ndims > target_ndims + 1) then - call safe_endrun(subname//': too many dimensions for '//trim(varname)) + call endrun(subname//': too many dimensions for '//trim(varname)) else if (ndims == target_ndims + 1) then ierr = pio_inq_dimname(ncid, dimids(ndims), tmpname) if (trim(tmpname) /= 'time') then - call safe_endrun(subname//': dimension mismatch for '//trim(varname)) + call endrun(subname//': dimension mismatch for '//trim(varname)) end if if (present(timelevel)) then if (timelevel > dimlens(ndims)) then write(errormsg, '(a,i0,a,i0)') ': timelevel, ', timelevel, & ', exceeds file limit, ', dimlens(ndims) - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if end if pdims = target_ndims else if (ndims < target_ndims) then - call safe_endrun(subname//': too few dimensions for '//trim(varname)) + call endrun(subname//': too few dimensions for '//trim(varname)) end if ! No else, things are okay call print_input_field_info(dimlens, pdims, 1, 3, dim_bounds, 2, & varname, subname) @@ -575,7 +576,7 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & ': Mismatch between array size (', arraydimsize(jndex), & ') and field size (', size(field, jndex), ') for ', & trim(varname), ', dimension = ', jndex - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if end do @@ -587,7 +588,7 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & trim(varname), ', file = ', dimlens(1), ', grid = ', & grid_dimlens(1), ' * ', grid_dimlens(2), ' = ', & (grid_dimlens(1) * grid_dimlens(2)) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if else if (unstruct) then index = 0 @@ -604,7 +605,7 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & write(errormsg, '(a,i0,2a,2(a,i0))') ': Dim ', jndex, & ' mismatch for ', trim(varname), ', file = ', & dimlens(jndex), 'grid = ', grid_dimlens(jndex+index) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if end do end if @@ -631,9 +632,9 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & if (single_column) then if (unstruct) then ! Clearly, this will not work for an unstructured dycore - call safe_endrun(subname//': SCAM not supported in this configuration') + call endrun(subname//': SCAM not supported in this configuration') else - call safe_endrun(subname//': SCAM support not implemented') + call endrun(subname//': SCAM support not implemented') end if else ! All distributed array processing @@ -649,13 +650,14 @@ subroutine infld_real8_2d(varname, ncid, field, readvar, gridname, & ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) !End run if PIO error occurred: if (ierr /= PIO_NOERR) then - write(errormsg, *) subname//': cam_pio_inq_var_fill failed with PIO error: ', ierr - call safe_endrun(errormsg) + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr + call endrun(errormsg) end if end if if (masterproc .and. log_read_field) then - write(iulog,*) subname//': read field '//trim(varname) + write(iulog,*) subname, ': read field ', trim(varname) end if end if ! end of readvar_tmp @@ -795,7 +797,7 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & else if (present(dim3_pos)) then if ((dim3_pos < 1) .or. (dim3_pos > 3)) then - call safe_endrun(subname//': Bad value for dim3_pos') + call endrun(subname//': Bad value for dim3_pos') end if index = dim3_pos else @@ -824,21 +826,21 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & varname, subname) ! Check to make sure that any 'extra' dimension is time if (ndims > target_ndims + 1) then - call safe_endrun(subname//': too many dimensions for '//trim(varname)) + call endrun(subname//': too many dimensions for '//trim(varname)) else if (ndims == target_ndims + 1) then ierr = pio_inq_dimname(ncid, dimids(ndims), tmpname) if (trim(tmpname) /= 'time') then - call safe_endrun(subname//': dimension mismatch for '//trim(varname)) + call endrun(subname//': dimension mismatch for '//trim(varname)) end if if (present(timelevel)) then if (timelevel > dimlens(ndims)) then write(errormsg, '(a,i0,a,i0)') ': timelevel, ', timelevel, & ', exceeds file limit, ', dimlens(ndims) - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if end if else if (ndims < target_ndims) then - call safe_endrun(subname//': too few dimensions for '//trim(varname)) + call endrun(subname//': too few dimensions for '//trim(varname)) end if ! No else, things are okay ! ! Get array dimension id's and sizes @@ -850,7 +852,7 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & if (arraydimsize(jndex) /= size(field, jndex)) then write(errormsg, '(4a,i0)') ': Mismatch between array bounds ', & 'and field size for ', trim(varname), ', dimension ', jndex - call safe_endrun(subname//errormsg) + call endrun(subname//errormsg) end if end do @@ -862,7 +864,7 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & trim(varname), ', file = ', dimlens(1), ', grid = ', & grid_dimlens(1), ' * ', grid_dimlens(2), ' = ', & (grid_dimlens(1) * grid_dimlens(2)) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if else do jndex = 1, target_ndims @@ -876,7 +878,7 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & write(errormsg, '(a,i0,2a,2(a,i0))') ': Dim ', jndex, & ' mismatch for ', trim(varname), ', file = ', & dimlens(jndex), 'grid = ', grid_dimlens(jndex+index) - call safe_endrun(subname//trim(errormsg)) + call endrun(subname//trim(errormsg)) end if end do end if @@ -894,9 +896,9 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & if (single_column) then if (unstruct) then ! Clearly, this will not work for an unstructured dycore - call safe_endrun(subname//': SCAM not supported in this configuration') + call endrun(subname//': SCAM not supported in this configuration') else - call safe_endrun(subname//': SCAM support not implemented') + call endrun(subname//': SCAM support not implemented') end if else ! All distributed array processing @@ -910,13 +912,14 @@ subroutine infld_real8_3d(varname, ncid, field, readvar, dim3name, & ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) !End run if PIO error occurred: if (ierr /= PIO_NOERR) then - write(errormsg, *) subname//': cam_pio_inq_var_fill failed with PIO error: ', ierr - call safe_endrun(errormsg) + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr + call endrun(errormsg) end if end if if (masterproc .and. log_read_field) then - write(iulog,*) subname//': read field '//trim(varname) + write(iulog,*) subname, ': read field ', trim(varname) end if end if ! end of readvar_tmp diff --git a/src/utils/cam_filenames.F90 b/src/utils/cam_filenames.F90 index d445ce1c..d1421c11 100644 --- a/src/utils/cam_filenames.F90 +++ b/src/utils/cam_filenames.F90 @@ -50,7 +50,7 @@ end function get_dir !=========================================================================== character(len=cl) function interpret_filename_spec(filename_spec, unit, & - prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec) + prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec, incomplete_ok) ! Create a filename from a filename specifier. The ! filename specifyer includes codes for setting things such as the @@ -68,6 +68,9 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & ! %% for the "%" character ! ! If is present and .true. label the file with previous time-step + ! If is present and .true., then wildcards without + ! values passed as optional dummy arguments will not generate an error. + ! This allows a partial resolution of the filename_spec. ! Dummy Arguments character(len=*), intent(in) :: filename_spec @@ -79,6 +82,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & integer, optional, intent(in) :: mon_spec integer, optional, intent(in) :: day_spec integer, optional, intent(in) :: sec_spec + logical, optional, intent(in) :: incomplete_ok ! Local variables integer :: year ! Simulation year @@ -91,6 +95,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & integer :: next ! Index location in logical :: previous ! If should label with previous time-step logical :: done + logical :: incomplete_ok_use character(len=*), parameter :: subname = "INTERPRET_FILENAME_SPEC: " !------------------------------------------------------------------------ @@ -98,9 +103,14 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & call endrun (subname//'filename specifier is empty') end if if (index(trim(filename_spec), " ") /= 0)then - call endrun(subname//"filename specifier can not contain a space:"// & + call endrun(subname//"filename specifier may not contain a space:"// & trim(filename_spec), file=__FILE__, line=__LINE__) end if + if (present(incomplete_ok)) then + incomplete_ok_use = incomplete_ok + else + incomplete_ok_use = .false. + end if ! ! Determine year, month, day and sec to put in filename ! @@ -110,7 +120,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & month = mon_spec day = day_spec ncsec = sec_spec - else + else if (.not. incomplete_ok_use) then if (present(prev)) then previous = prev else @@ -121,7 +131,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & else call get_curr_date(year, month, day, ncsec) end if - end if + end if ! No else, do not use these quantities below. ! ! Go through each character in the filename specifyer and interpret ! if it is a format specifier @@ -138,11 +148,25 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & case('c') ! caseid if (present(case)) then string = trim(case) - else + else if (len_trim(caseid) > 0) then string = trim(caseid) + else if (incomplete_ok_use) then + string = "%c" + else + write(string, *) "case needed in filename_spec, ", & + "but not provided to subroutine, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) end if case('u') ! unit description (e.g., h2) - if (.not. present(unit)) then + if (present(unit)) then + string = trim(unit) + else if (incomplete_ok_use) then + string = "%u" + else write(string, *) "unit needed in filename_spec, ", & "but not provided to subroutine, filename_spec = '", & trim(filename_spec), "'" @@ -151,9 +175,12 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & end if call endrun(subname//trim(string)) end if - string = trim(unit) case('i') ! instance description (e.g., _0001) - if (.not. present(instance)) then + if (present(instance)) then + string = trim(instance) + else if (incomplete_ok_use) then + string = "%i" + else write(string, *) "instance needed in filename_spec, ", & "but not provided to subroutine, filename_spec = '", & trim(filename_spec), "'" @@ -162,22 +189,37 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & end if call endrun(subname//trim(string)) end if - string = trim(instance) case('y') ! year - if (year > 99999) then - fmt_str = '(i6.6)' - else if (year > 9999) then - fmt_str = '(i5.5)' + if (.not. present(yr_spec) .and. incomplete_ok_use) then + string = '%y' else - fmt_str = '(i4.4)' + if (year > 99999) then + fmt_str = '(i6.6)' + else if (year > 9999) then + fmt_str = '(i5.5)' + else + fmt_str = '(i4.4)' + end if + write(string,fmt_str) year end if - write(string,fmt_str) year case('m') ! month - write(string,'(i2.2)') month + if (.not. present(mon_spec) .and. incomplete_ok_use) then + string = '%m' + else + write(string,'(i2.2)') month + end if case('d') ! day - write(string,'(i2.2)') day + if (.not. present(day_spec) .and. incomplete_ok_use) then + string = '%d' + else + write(string,'(i2.2)') day + end if case('s') ! second - write(string,'(i5.5)') ncsec + if (.not. present(sec_spec) .and. incomplete_ok_use) then + string = '%s' + else + write(string,'(i5.5)') ncsec + end if case('%') ! percent character string = "%" case default @@ -202,7 +244,9 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & interpret_filename_spec = trim(string) else if ((len_trim(interpret_filename_spec)+len_trim(string)) >= cl) then - call endrun(subname//"Resultant filename too long") + call endrun(subname// & + "Resultant filename too long, trying to add: '"// & + trim(string)//"' to '"//trim(interpret_filename_spec)//"'") end if interpret_filename_spec = trim(interpret_filename_spec)//trim(string) end if diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90 index 43c55c20..76213433 100644 --- a/src/utils/cam_pio_utils.F90 +++ b/src/utils/cam_pio_utils.F90 @@ -1230,7 +1230,7 @@ end subroutine clean_iodesc_list subroutine cam_pio_createfile(file, fname, mode_in) use pio, only : pio_createfile, file_desc_t, pio_noerr use pio, only: pio_64bit_offset, pio_iotask_rank, pio_clobber - use cam_abortutils, only : endrun, cam_register_open_file + use cam_abortutils, only : endrun ! Dummy arguments type(file_desc_t), intent(inout) :: file @@ -1250,9 +1250,6 @@ subroutine cam_pio_createfile(file, fname, mode_in) if(ierr /= PIO_NOERR) then call endrun('Failed to open file,'//trim(fname)//', to write') - else if(pio_iotask_rank(pio_subsystem) == 0) then - write(iulog, *) 'Opened file ', trim(fname), ' to write', file%fh - call cam_register_open_file(file, trim(fname)) end if end subroutine cam_pio_createfile @@ -1261,7 +1258,7 @@ end subroutine cam_pio_createfile subroutine cam_pio_openfile(file, fname, mode, log_info) use pio, only: pio_openfile, file_desc_t use pio, only: pio_noerr, pio_iotask_rank - use cam_abortutils, only: endrun, cam_register_open_file + use cam_abortutils, only: endrun type(file_desc_t), intent(inout), target :: file character(len=*), intent(in) :: fname @@ -1281,9 +1278,6 @@ subroutine cam_pio_openfile(file, fname, mode, log_info) if(ierr /= PIO_NOERR) then call endrun('Failed to open '//trim(fname)//' to read') - else if(pio_iotask_rank(pio_subsystem) == 0 .and. log_information) then - write(iulog,*) 'Opened existing file ', trim(fname), file%fh - call cam_register_open_file(file, trim(fname)) end if end subroutine cam_pio_openfile @@ -1292,12 +1286,10 @@ end subroutine cam_pio_openfile subroutine cam_pio_closefile(file) use pio, only: pio_closefile, file_desc_t - use cam_abortutils, only: cam_register_close_file type(file_desc_t), intent(inout), target :: file call pio_closefile(file) - call cam_register_close_file(file) end subroutine cam_pio_closefile diff --git a/test/hist_tests/CMakeLists.txt b/test/hist_tests/CMakeLists.txt index 87a5f8a2..e1c84e53 100644 --- a/test/hist_tests/CMakeLists.txt +++ b/test/hist_tests/CMakeLists.txt @@ -9,6 +9,8 @@ add_definitions(${MPI_Fortran_COMPILE_FLAGS}) include_directories(${MPI_Fortran_INCLUDE_PATH}) link_directories(${MPI_Fortran_LIBRARIES}) +# Command line switches +SET(ABORT "OFF" CACHE BOOL "If ON, endrun aborts job") #----------------------------------------------------------------------------- # # Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) @@ -28,7 +30,9 @@ else(EXISTS "${ROOT_PATH}/cime") SET(CIME_PATH ${_toplev}/cime) endif(EXISTS "${ROOT_PATH}/cime") # Test copies of CAM and CIME utility files -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_abortutils.F90") +if (NOT ${ABORT}) + LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_abortutils.F90") +endif(NOT ${ABORT}) LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_logfile.F90") LIST(APPEND SOURCE_FILES "${UTILS_PATH}/ccpp_kinds.F90") LIST(APPEND SOURCE_FILES "${UTILS_PATH}/spmd_utils.F90") @@ -51,6 +55,10 @@ LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_nl_mod.F90") LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_strconvert_mod.F90") LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_filenames.F90") +if (${ABORT}) + LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_abortutils.F90") + LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_mem_mod.F90") +endif(${ABORT}) # CAM history files LIST(APPEND SOURCE_FILES "${HIST_PATH}/cam_hist_file.F90") ## We need to copy shr_assert.h into this directory diff --git a/test/hist_tests/run_test b/test/hist_tests/run_test index 39d44ccb..3ee880b2 100755 --- a/test/hist_tests/run_test +++ b/test/hist_tests/run_test @@ -9,6 +9,7 @@ scriptdir="$( cd $( dirname $0 ); pwd -P )" defdir="build" build_dir="${currdir}/${defdir}" cleanup="PASS" # Other supported options are ALWAYS and NEVER +abort="OFF" # Use "ON" to use real endrun call verbosity=0 ## @@ -18,13 +19,14 @@ verbosity=0 help () { local hname="Usage: `basename ${0}`" local hprefix="`echo ${hname} | tr '[!-~]' ' '`" - echo "${hname} [ --build-dir ] [ --cleanup ]" + echo "${hname} [ --build-dir ] [ --cleanup ] [ --abort ]" hprefix=" " echo "" echo "${hprefix} : Directory for building and running the test" echo "${hprefix} default is /${defdir}" echo "${hprefix} : Cleanup option is ALWAYS, NEVER, or PASS" echo "${hprefix} default is PASS" + echo "${hprefix} --abort will cause endrun calls to stop test (debug only)" exit $1 } @@ -55,6 +57,9 @@ while [ $# -gt 0 ]; do --h | -h | --help | -help) help 0 ;; + --abort) + abort="ON" + ;; --build-dir) if [ $# -lt 2 ]; then perr "${1} requires a build directory" @@ -113,6 +118,9 @@ if [ $res -ne 0 ]; then fi # Run CMake opts="" +if [ "${abort}" == "ON" ]; then + opts="${opts} -DABORT=ON" +fi cmake ${scriptdir} ${opts} res=$? if [ $res -ne 0 ]; then diff --git a/test/hist_tests/sample_files/single_good_config.nl b/test/hist_tests/sample_files/single_good_config.nl index 61bbf17d..cae541a8 100644 --- a/test/hist_tests/sample_files/single_good_config.nl +++ b/test/hist_tests/sample_files/single_good_config.nl @@ -13,4 +13,5 @@ hist_precision = 'REAL32' hist_max_frames = 13 hist_output_frequency = '2*hours' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / diff --git a/test/hist_tests/sample_files/two_good_configs.nl b/test/hist_tests/sample_files/two_good_configs.nl index 31e28334..baa92e71 100644 --- a/test/hist_tests/sample_files/two_good_configs.nl +++ b/test/hist_tests/sample_files/two_good_configs.nl @@ -14,6 +14,7 @@ hist_max_frames = 13 hist_output_frequency = '2*hours' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / &hist_file_config_nl @@ -23,4 +24,5 @@ hist_max_frames = 30 hist_output_frequency = 'monthly' hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' / diff --git a/test/hist_tests/sample_files/user_nl_cam_defaults b/test/hist_tests/sample_files/user_nl_cam_defaults new file mode 100644 index 00000000..a468a543 --- /dev/null +++ b/test/hist_tests/sample_files/user_nl_cam_defaults @@ -0,0 +1,17 @@ +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value + +ncdata = 'atm/cam/inic/se/ape_topo_cam4_ne16np4_L32_c171020.nc' +use_topo_file = .false. + +history_no_defaults: False +! History configuration +diag_file;h0: amwg_hist_config +remove_avg_fields;h0 TAUTMSX, TAUTMSY +output_levels;h0: IPCC_PRESSURE_LEVELS +add_pressure_levels;h0: 925hPa, 850, 500, 320 + + +output_levels;h3: MODEL_LEVELS +add_inst_fields;h3: T, U, V +output_frequency;h3: 2*nsteps diff --git a/test/hist_tests/test_history.F90 b/test/hist_tests/test_history.F90 index 18131933..82767c34 100644 --- a/test/hist_tests/test_history.F90 +++ b/test/hist_tests/test_history.F90 @@ -59,10 +59,10 @@ subroutine run_test(test_msg, test_file, sample_dir, out_unit, & test_cnt = test_cnt + 1 ! Is volume correct? if (trim(tconfig_arr(indx)%filename()) /= trim(volumes(indx))) then err_cnt = err_cnt + 1 - write(out_unit, '(3a,i0,4a)') "FAIL: ", trim(test_msg), & - ": volume(", indx, ") is ", & - trim(tconfig_arr(indx)%filename()), ", should be ", & - trim(volumes(indx)) + write(out_unit, '(3a,i0,5a)') "FAIL: ", trim(test_msg), & + ": volume(", indx, ") is '", & + trim(tconfig_arr(indx)%filename()), "', should be '", & + trim(volumes(indx)), "'" end if test_cnt = test_cnt + 1 ! Is max_frames correct? if (tconfig_arr(indx)%max_frame() /= max_frames(indx)) then @@ -147,8 +147,9 @@ program test_history ! Read single-good config test test_file = "single_good_config.nl" test_msg = "single_good_config.nl file read test" - call run_test(test_msg, test_file, sample_dir, out_unit, 1, (/ 'h1' /), & - (/ 13 /), (/ 'REAL32' /), testcnt, errcnt) + call run_test(test_msg, test_file, sample_dir, out_unit, 1, & + (/ "%c.cam.h1.%y-%m-%d-%s.nc" /), (/ 13 /), & + (/ 'REAL32' /), testcnt, errcnt) total_tests = total_tests + testcnt total_errcnt = total_errcnt + errcnt @@ -156,8 +157,8 @@ program test_history test_file = "two_good_configs.nl" test_msg = "two_good_configs.nl file read test" call run_test(test_msg, test_file, sample_dir, out_unit, 2, & - (/ 'h1', 'h0' /), (/ 13, 30 /), (/ 'REAL32', 'REAL64' /), & - testcnt, errcnt) + (/ "%c.cam.h1.%y-%m-%d-%s.nc", "%c.cam.h0.%y-%m-%d-%s.nc" /), & + (/ 13, 30 /), (/ 'REAL32', 'REAL64' /), testcnt, errcnt) total_tests = total_tests + testcnt total_errcnt = total_errcnt + errcnt diff --git a/test/include/cam_control_mod.F90 b/test/include/cam_control_mod.F90 index 6fe16373..ceae6c0e 100644 --- a/test/include/cam_control_mod.F90 +++ b/test/include/cam_control_mod.F90 @@ -21,8 +21,8 @@ module cam_control_mod ! cam_ctrl_set_orbit ! cam_ctrl_set_physics_type - character(len=cl), protected :: caseid ! case ID - character(len=cl), protected :: ctitle ! case title + character(len=cl), protected :: caseid = '' ! case ID + character(len=cl), protected :: ctitle = '' ! case title logical, protected :: initial_run ! startup mode which only requires a minimal initial file logical, protected :: restart_run ! continue a previous run; requires a restart file diff --git a/test/include/shr_mem_mod.F90 b/test/include/shr_mem_mod.F90 new file mode 100644 index 00000000..e0844891 --- /dev/null +++ b/test/include/shr_mem_mod.F90 @@ -0,0 +1,63 @@ +MODULE shr_mem_mod + + use shr_kind_mod, only : shr_kind_r8 + use shr_log_mod, only: s_logunit => shr_log_Unit + use shr_sys_mod, only: shr_sys_abort + + implicit none + private + + ! PUBLIC: Public interfaces + + public :: shr_mem_getusage, & + shr_mem_init + + ! PUBLIC: Public interfaces + + real(shr_kind_r8) :: mb_blk = 0.0_shr_kind_r8 + + !=============================================================================== +CONTAINS + !=============================================================================== + + subroutine shr_mem_init(prt, strbuf) + + implicit none + + !----- arguments ----- + + logical, optional :: prt + character(len=*), optional :: strbuf + !----- local ----- + + ! --- Memory stats --- + integer :: msize ! memory size (high water) + integer :: mrss0,mrss1,mrss2 ! temporary rss + integer :: mshare,mtext,mdatastack + logical :: lprt + integer :: ierr + + integer :: GPTLget_memusage + + real(shr_kind_r8),allocatable :: mem_tmp(:) + + character(*),parameter :: subname = "(shr_mem_init)" + !--------------------------------------------------- + + end subroutine shr_mem_init + + !=============================================================================== + + subroutine shr_mem_getusage(r_msize,r_mrss,prt) + + implicit none + + !----- arguments --- + real(shr_kind_r8) :: r_msize,r_mrss + logical, optional :: prt + + end subroutine shr_mem_getusage + + !=============================================================================== + +END MODULE shr_mem_mod diff --git a/test/include/shr_string_mod.F90 b/test/include/shr_string_mod.F90 index 84ba7a32..ba10295d 100644 --- a/test/include/shr_string_mod.F90 +++ b/test/include/shr_string_mod.F90 @@ -77,7 +77,6 @@ module shr_string_mod public :: shr_string_listDiff ! get set difference of two field lists public :: shr_string_listMerge ! merge two lists to form third public :: shr_string_listAppend ! append list at end of another - public :: shr_string_listPrepend ! prepend list in front of another public :: shr_string_listSetDel ! Set field delimiter in lists public :: shr_string_listGetDel ! Get field delimiter in lists public :: shr_string_listFromSuffixes! return colon delimited field list @@ -1363,75 +1362,6 @@ subroutine shr_string_listAppend(list,listadd,rc) end subroutine shr_string_listAppend - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listPrepend -- Prepend one list to another - ! - ! !DESCRIPTION: - ! Prepend one list to another - ! \newline - ! call shr\_string\_listPrepend(listadd,list) - ! \newline - ! results in listadd:list - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listPrepend(listadd,list,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: listadd ! list/string - character(*) ,intent(inout) :: list ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - character(SHR_KIND_CX) :: l1 ! local string - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listPrepend) " - character(*),parameter :: F00 = "('(shr_string_listPrepend) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! - no input or output string should be longer than SHR_KIND_CX - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - rCode = 0 - - !--- make sure temp string is large enough --- - if (len(l1) < len_trim(listAdd)) then - call shr_string_abort(subName//'ERROR: temp string not large enough') - end if - - call shr_string_clean(l1) - l1 = trim(listadd) - call shr_string_leftalign_and_convert_tabs(l1,rCode) - call shr_string_leftalign_and_convert_tabs(list,rCode) - if (len_trim(list)+len_trim(l1)+1 > len(list)) & - call shr_string_abort(subName//'ERROR: output list string not large enough') - if (len_trim(l1) == 0) then - list = trim(list) - else - list = trim(l1)//":"//trim(list) - endif - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listPrepend - !=============================================================================== !BOP =========================================================================== ! From e4fa834c699e6d7609c2ee92d7bb6d3d65b70ed8 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 1 Mar 2024 11:28:59 -0700 Subject: [PATCH 10/79] Updating Externals_CAM.cfg to point to tj2016 atmospheric physics fork. --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index f179217c..82c09584 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -16,8 +16,8 @@ required = True [ncar-physics] local_path = src/physics/ncar_ccpp protocol = git -repo_url = https://github.com/ESCOMP/atmospheric_physics -tag = atmos_phys0_01_000 +repo_url = https://github.com/mwaxmonsky/atmospheric_physics +tag = 3c1d72c3b8e641da00ca10e485e9877dc9cc167f required = True [externals_description] From 19e15862221f97d15f4891532dea9422a6d1a0ec Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 15 Mar 2024 09:00:08 -0600 Subject: [PATCH 11/79] Merging in updates from ccpp-framework and atmospheric_physcis. Updating gravit standard name. Making etamid visible via metadata file. --- Externals_CAM.cfg | 2 +- src/data/physconst.meta | 2 +- src/data/registry.xml | 9 +++++++++ src/dynamics/utils/hycoef.F90 | 15 +++++++++------ src/dynamics/utils/hycoef.meta | 13 +++++++++++++ 5 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 src/dynamics/utils/hycoef.meta diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 13faa617..a77df05e 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = 3c1d72c3b8e641da00ca10e485e9877dc9cc167f +tag = 9705c32c2c2e9b47655a3a057d25b5acbed20210 required = True [externals_description] diff --git a/src/data/physconst.meta b/src/data/physconst.meta index b3646d73..c900f8f4 100644 --- a/src/data/physconst.meta +++ b/src/data/physconst.meta @@ -201,7 +201,7 @@ dimensions = () protected = True [ gravit ] - standard_name = gravitational_acceleration + standard_name = standard_gravitational_acceleration units = m s-2 type = real | kind = kind_phys dimensions = () diff --git a/src/data/registry.xml b/src/data/registry.xml index ea01fc06..ab89a887 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -15,6 +15,7 @@ $SRCROOT/src/data/cam_thermo.meta $SRCROOT/src/data/ref_pres.meta $SRCROOT/src/dynamics/utils/vert_coord.meta + $SRCROOT/src/dynamics/utils/hycoef.meta @@ -355,5 +356,13 @@ horizontal_dimension vertical_layer_dimension zvir + + ff + horizontal_dimension vertical_layer_dimension + tendency_of_air_enthalpy + diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 02c983dc..5d807c24 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -1,6 +1,7 @@ module hycoef use shr_kind_mod, only: r8 => shr_kind_r8 +use ccpp_kinds, only: kind_phys use spmd_utils, only: masterproc use vert_coord, only: pver, pverp use cam_logfile, only: iulog @@ -28,8 +29,6 @@ module hycoef real(r8), public, allocatable, target :: hybi(:) ! ps component of hybrid coordinate - interfaces real(r8), public, allocatable, target :: hybm(:) ! ps component of hybrid coordinate - midpoints -real(r8), public, allocatable :: etamid(:) ! hybrid coordinate - midpoints - real(r8), public, allocatable :: hybd(:) ! difference in b (hybi) across layers real(r8), public, allocatable :: hypi(:) ! reference pressures at interfaces real(r8), public, allocatable :: hypm(:) ! reference pressures at midpoints @@ -47,6 +46,10 @@ module hycoef type(var_desc_t) :: hyam_desc, hyai_desc, hybm_desc, hybi_desc, p0_desc public init_restart_hycoef, write_restart_hycoef +!> \section arg_table_hycoef Argument Table +!! \htmlinclude hycoef.html +real(kind_phys), public, :: etamid(pver) ! hybrid coordinate - midpoints + !======================================================================= contains !======================================================================= @@ -123,10 +126,10 @@ subroutine hycoef_init(file, psdry) call endrun(subname//': allocate hybm(pver) failed with stat: '//to_str(iret)) end if - allocate(etamid(pver), stat=iret) - if (iret /= 0) then - call endrun(subname//': allocate etamid(pver) failed with stat: '//to_str(iret)) - end if + !allocate(etamid(pver), stat=iret) + !if (iret /= 0) then + ! call endrun(subname//': allocate etamid(pver) failed with stat: '//to_str(iret)) + !end if allocate(hybd(pver), stat=iret) if (iret /= 0) then diff --git a/src/dynamics/utils/hycoef.meta b/src/dynamics/utils/hycoef.meta new file mode 100644 index 00000000..ef3121fa --- /dev/null +++ b/src/dynamics/utils/hycoef.meta @@ -0,0 +1,13 @@ +[ccpp-table-properties] + name = hycoef + type = module +[ccpp-arg-table] + name = hycoef + type = module + +[ etamid ] + standard_name = sum_of_sigma_pressure_hybrid_coordinate_a_coefficient_and_sigma_pressure_hybrid_coordinate_b_coefficient + type = real | kind = kind_phys + units = 1 + dimensions = (vertical_layer_dimension) + From 680d5a8cf0de7c43e4bb168a91177b36d3547ffc Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Wed, 3 Apr 2024 14:20:41 -0600 Subject: [PATCH 12/79] Updates based on bug fixes and feedback. --- Externals_CAM.cfg | 2 +- src/data/CCPP Standard Names - Sheet1.csv | 684 ++++++++++++++++++ src/data/generate_input_to_stdnames_update.py | 60 ++ src/data/inputnames_to_stdnames.py | 15 +- src/data/registry.xml | 8 - .../stdnames_to_inputnames_dictionary.xml | 6 +- src/dynamics/utils/hycoef.F90 | 68 +- 7 files changed, 819 insertions(+), 24 deletions(-) create mode 100644 src/data/CCPP Standard Names - Sheet1.csv create mode 100644 src/data/generate_input_to_stdnames_update.py diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index a77df05e..b75f9557 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = 9705c32c2c2e9b47655a3a057d25b5acbed20210 +tag = 8e04841df78634fd38b6826af893485e0ecdbf8f required = True [externals_description] diff --git a/src/data/CCPP Standard Names - Sheet1.csv b/src/data/CCPP Standard Names - Sheet1.csv new file mode 100644 index 00000000..dfb085aa --- /dev/null +++ b/src/data/CCPP Standard Names - Sheet1.csv @@ -0,0 +1,684 @@ +Snapshot Variable Name,Snapshot Longname,Longname Location,Snapshot Units,Accepted Units,CCPP Standard Name,Accepted,Pushed to ESCOMP,Flag for future work,Flag to skip/deprecate,Notes,Andrew G Description,,, +lat,latitude,snapshot file,degrees north,X,latitude,X,X,,,Jesse,,,, +lon,longitude,snapshot file,degrees east,X,longitude,X,X,,,Cheryl,,,, +gw,latitude weights,snapshot file,1,X,area_weight_wrt_latitude,X,,,X,Courtney,,,, +lev,hybrid level at midpoints,snapshot file,hPa,X,reference_pressure_in_atmosphere_layer,x,X,,,,,,, +hyam,hybrid A coefficient at layer midpoints,snapshot file,1,X,sigma_pressure_hybrid_coordinate_a_coefficient,X,,,,,,,, +hybm,hybrid B coefficient at layer midpoints,snapshot file,1,X,sigma_pressure_hybrid_coordinate_b_coefficient,X,,,,FIX UNITS!,,,, +P0,reference pressure,snapshot file,Pa,X,reference_pressure,X,X,,,,,,, +ilev,hybrid level at interfaces (1000*(A+B)),snapshot file,hPa,X,reference_pressure_in_atmosphere_layer_at_interface,,,,,,,,, +hyai,hybrid A coefficient at layer interfaces,snapshot file,1,X,sigma_pressure_hybrid_coordinate_a_coefficient_at_interface,,,,,,,,, +hybi,hybrid B coefficient at layer interfaces,snapshot file,1,X,sigma_pressure_hybrid_coordinate_b_coefficient_at_interface,,,,,,,,, +trop_cld_lev,troposphere hybrid level at midpoints (1000*(A+B)),snapshot file,hPa,X,,,,only used in PUMAS,X,,,,, +time,time,snapshot file,days since 0001-01-01 00:00:00,,fractional_days_since_model_start,,,,,,,,, +date,current date (YYYYMMDD),snapshot file,,,current_model_date_in_ISO_order,,,year needs to be 0-padded,,,,,, +datesec,current seconds of current date,snapshot file,,,seconds_of_current_model_date,,,,,,,,, +time_bnds,time interval endpoints,snapshot file,,,,,,,X,,,,, +date_written,date time sample written,cam_history_support.F90: line 209,,,,,,,X,,,,, +time_written,time time sample written,cam_history_support.F90: line 210,,,,,,,X,,,,, +ndbase,base day,snapshot file,,,,,,what is using this?,,,,,, +nsbase,seconds of base day,snapshot file,,,,,,what is using this?,,,,,, +nbdate,base date (YYYYMMDD),snapshot file,,,,,,what is using this?,,,,,, +nbsec,seconds of base date,snapshot file,,,,,,what is using this?,,,,,, +mdt,timestep,snapshot file,s,X,timestep_for_physics,,X,,,,,,, +ndcur,current day (from base day),snapshot file,,,,,,what is using this?,,,,,, +nscur,current seconds of current day,snapshot file,,,,,,what is using this?,,,,,, +co2vmr,co2 volume mixing ratio,snapshot file,mol mol-1,,volume_mixing_ratio_of_co2_wrt_dry_air,X,,"Needs to be ""of_co2"" and ""wrt_dry_air""","""wrt_dry_air"" may be redundant, but is clear!",units: check with chemists,,,, +ch4vmr,ch4 volume mixing ratio,snapshot file,,,volume_mixing_ratio_ch4,,,"""",,units: check with chemists,,,, +n2ovmr,n20 volume mixing ratio,snapshot file,,,volume_mixing_ratio_n2o,,,"""",,units: check with chemists,,,, +f11vmr,f11 volume mixing ratio,snapshot file,,,volume_mixing_ratio_cfc11,,,"""",,units: check with chemists,,,, +f12vmr,f12 volume mixing ratio,snapshot file,,,volume_mixing_ratio_cfc12,,,"""",,,,,, +sol_tsi,total solar irradiance,snapshot file,W m-2,X,total_solar_irradiance,,,ask chemist - are we using this?,,,,,, +nstep,current timestep,snapshot file,count,X,current_timestep_number,,,,,,,,, +CAM_IN VARIABLES,,,,,,,,,,,,,, +cam_in_aldif,long wave diffuse albedo,camsrfexch.F90: 91,frac,X,surface_albedo_due_to_near_IR_diffuse,,,,,,,,, +cam_in_aldir,long wave direct albedo,camsrfexch.F90: 90,frac,X,surface_albedo_due_to_near_IR_direct,,,,,,,,, +cam_in_asdif,short wave diffuse albedo,camsrfexch.F90: 93,frac,X,surface_albedo_due_to_UV_and_VIS_diffuse,,,,,,,,, +cam_in_asdir,short wave direct albedo,camsrfexch.F90: 92,frac,X,surface_albedo_due_to_UV_and_VIS_direct,,,,,,,,, +cam_in_cflx,constituent flux (emissions),camsrfexch.F90: 112,kg m-2 s-1,X,surface_upward_ccpp_constituent_fluxes,,,,,,,,, +cam_in_depvel,deposition velocities,camsrfexch.F90: line 119,m s-1,,dry_deposition_velocity,,,Have ACOM check this!,,units: check with chemists,,,, +cam_in_dstflx,dust fluxes,camsrfexch.F90: line 120,kg m-2 s-1,,surface_upward_dust_fluxes,,,Have ACOM check this! Also units!,,units: check with chemists,,,, +cam_in_fv,friction velocity,camsrfexch.F90: line 117,m s-1,X,surface_friction_velocity,X,X,,,,,,, +cam_in_icefrac,sea-ice area fraction,camsrfexch.F90: line 110,frac,X,sea_ice_area_fraction,,,"Need to add rule that ""fraction"" means fraction of atmosphere grid cell",Fraction units?,,,,, +cam_in_landfrac,land area fraction,camsrfexch.F90: line 109,frac,X,land_area_fraction,X,X,,,,,,, +cam_in_lhf,latent heat flux,camsrfexch.F90: line 95,W m-2,X,surface_upward_latent_heat_flux,X,X,,,,,,, +cam_in_lwup,longwave up radiative flux,camsrfexch.F90: line 94,W m-2,X,,,,wait until we finish RRTMGP,,,,,, +cam_in_ocnfrac,ocean area fraction,camsrfexch.F90: line 111,frac,X,ocean_area_fraction,X,,,,,,,, +cam_in_ram1,aerodynamical resistance,camsrfexch.F90: line 116,s m-1,X,,,,Need ACOM to check this,"Also the ""addfld"" units might be wrong",,,,, +cam_in_shf,sensible heat flux,camsrfexch.F90: line 96,W m-2,X,surface_upward_sensible_heat_flux,X,,,,,,,, +cam_in_snowhice,snow depth over ice,camsrfexch.F90: line 105,m,X,lwe_surface_snow_depth_over_ice,X,,,,,,,, +cam_in_snowhland,snow depth (liquid water equivalent) over land,camsrfexch.F90: line 104,m,X,lwe_surface_snow_depth_over_land,X,,,,,,,, +cam_in_sst,sea surface temp,camsrfexch.F90: line 103,K,X,sea_surface_temperature,X,X,,,,,,, +cam_in_ts,merged surface temp,camsrfexch.F90: line 102,K,X,surface_blackbody_temperature (might be same as surface_skin_temperature used by NOAA?),,,"ask NOAA about ""skin"" temperature",,,,,, +cam_in_wsx,surface u-stress,camsrfexch.F90: line 97,N m-2,X,surface_eastward_wind_stress,,,,,Units wrong in camsrfexch.F90,,,, +cam_in_wsy,surface v-stress,camsrfexch.F90: line 98,N m-2,X,surface_northward_wind_stress,,,,,Units wrong in camsrfexch.F90,,,, +CAM_OUT_VARIABLES,,,,,,,,,,,,,, +cam_out_bcphidry,dry deposition of hydrophilic black carbon,camsrfexch.F90: line 66,kg m-2 s-1,,dry_deposition_flux_of_hydrophilic_black_carbon_at_surface,,,,,,,,, +cam_out_bcphiwet,wet deposition of hydrophilic black carbon,camsrfexch.F90: line 65,kg m-2 s-1,,wet_deposition_flux_of_hydrophilic_black_carbon_at_surface,,,,,,,,, +cam_out_bcphodry,dry deposition of hydrophobic black carbon,camsrfexch.F90: line 67,kg m-2 s-1,,dry_deposition_flux_of_hydrophobic_black_carbon_at_surface,,,,,,,,, +cam_out_dstdry1,dry deposition of dust (bin1),camsrfexch.F90: line 72,,,,,,,,,,,, +cam_out_dstdry2,dry deposition of dust (bin2),camsrfexch.F90: line 71,,,,,,,,,,,, +cam_out_dstdry3,dry deposition of dust (bin3),camsrfexch.F90: line 74,,,,,,,,,,,, +cam_out_dstdry4,dry deposition of dust (bin4),camsrfexch.F90: line 73,,,,,,,,,,,, +cam_out_dstwet1,wet deposition of dust (bin1),camsrfexch.F90: line 76,,,,,,,,,,,, +cam_out_dstwet2,wet deposition of dust (bin2),camsrfexch.F90: line 75,,,,,,,,,,,, +cam_out_dstwet3,wet deposition of dust (bin3),camsrfexch.F90: line 78,,,,,,,,,,,, +cam_out_dstwet4,wet deposition of dust (bin4),camsrfexch.F90: line 77,,,,,,,,,,,, +cam_out_netsw,surface solar absorbed flux (shortwave),radiation.F90: line 771,,,,,,,,,,,, +cam_out_ocphidry,dry deposition of hydrophilic organic carbon,camsrfexch.F90: line 69,kg m-2 s-1,,dry_deposition_flux_of_hydrophilic_organic_carbon_at_surface,,,,,,,,, +cam_out_ocphiwest,wet deposition of hydrophilic organic carbon,camsrfexch.F90: line 68,kg m-2 s-1,,wet_deposition_flux_of_hydrophilic_organic_carbon_at_surface,,,,,,,,, +cam_out_ocphodry,dry deposition of hydrophobic organic carbon,camsrfexch.F90: line 70,kg m-2 s-1,,dry_deposition_flux_of_hydrophobic_organic_carbon_at_surface,,,,,,,,, +cam_out_precc,convective precipitation rate,camsrfexch.F90: line 520,m s-1,X,lwe_convective_precipitation_rate_at_surface,X,,,,,,,, +cam_out_precl,stratiform precipitation rate,camsrfexch.F90: line 520,m s-1,X,lwe_large_scale_precipitation_rate_at_surface,X,,,,,,,, +cam_out_precsc,convection snow rate,camsrfexch.F90: line 520,m s-1,X,lwe_convective_snowfall_rate_at_surface,X,,,,,,,, +cam_out_precsl,stratiform snow rate,camsrfexch.F90: line 520,m s-1,X,lwe_large_scale_snowfall_rate_at_surface,X,,,,,,,, +cam_out_soll,direct solar rad on surface (>=0.7),radsw.F90: line 153,W m-2,X,,,,Will find in RRTMGP,,,,,, +cam_out_solld,diffuse solar rad on surface (>=0.7),radsw.F90: line 155,W m-2,X,,,,Will find in RRTMGP,,,,,, +cam_out_sols,direct solar rad on surface (<0.7),radsw.F90: line 152,W m-2,X,,,,Will find in RRTMGP,,,,,, +cam_out_solsd,diffuse solar rad on surface (<0.7),radsw.F90: line 154,W m-2,X,,,,Will find in RRTMGP,,,,,, +CONSTITUENT VARIABLES,,,,,,,,,,,,,, +pcnst,number of constituents,,count,X,,,,number_of_tracers (iap_dom and github),,,,,, +cnst_CLDICE,cloud ice amount,micro_pumas_cam.F90: line 120,kg kg-1,X,cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water,,,"OK name, but not in repo (have wrt_dry_air and interstitial)",,,,,, +cnst_CLIDLIQ,cloud liquid amount,micro_pumas_cam.F90: line 120,kg kg-1,X,cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water,,X,,,,,,, +cnst_DMS,,,kg kg-1,X,,,,,,,,,, +cnst_GRAUQM,graupel amount,micro_pumas_cam.F90: line 120,kg kg-1,X,graupel_water_mixing_ratio_wrt_moist_air,,X,,,,,,, +cnst_H2O2,,,kg kg-1,X,,,,,,,,,, +cnst_H2SO4,,,kg kg-1,X,,,,,,,,,, +cnst_NUMGRA,graupel number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_graupel_wrt_moist_air,X,,,,,,,, +cnst_NUMICE,cloud ice number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_ice_wrt_moist_air,X,,,,,,,, +cnst_NUMLIQ,cloud liquid number,micro_pumas_cam.F90: line 120, kg-1,X,mass_number_concentration_of_cloud_liquid_wrt_moist_air,X,,,,,,,, +cnst_NUMRAI,rain number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_rain_wrt_moist_air,X,,,,,,,, +cnst_NUMSNO,snow number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_snow_wrt_moist_air,X,,,,,,,, +"cnst_Q and state%q(:,:,1)",water vapor amount,micro_pumas_cam.F90: line 120,kg kg-1,X,water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water,,X,,,,,,, +cnst_RAINQM,rain amount,micro_pumas_cam.F90: line 120,kg kg-1,X,rain_mixing_ratio_wrt_moist_air_and_condensed_water,,-,"drop ""water"" for rain and snow",,,,,, +cnst_SNOWQM,snow amount,micro_pumas_cam.F90: line 120,kg kg-1,X,snow_mixing_ratio_wrt_moist_air_and_condensed_water,,,snow_mixing_ratio_wrt_moist_air in repo,,,,,, +cnst_SO2,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_SOAG,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_bc_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_bc_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_dst_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_dst_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_dst_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_ncl_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_ncl_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_ncl_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_num_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_num_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_num_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_num_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_pom_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_pom_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_so4_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_so4_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_so4_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_soa_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, +cnst_soa_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, +PBUF VARIABLES,,,,,,,,,,,,,, +pbuf_ACCRE_ENHAN,accretion enhancment factor,micro_pumas_cam.F90: line 73,1,X,,,,,SKIP,vestigial - can remove; not in GSL meta file,relative variance?,MG interface meta file: https://github.com/NOAA-GSL/ccpp-physics/blob/gsl/develop/physics/m_micro.meta,, +pbuf_ACGCME,accumulated condensation,micro_pumas_cam.F90: line 740,,,accumulated_condensation_minus_evaporation_due_to_microphysics,,,,,diagnostic; not in GSL meta file,,,, +pbuf_ACNUM,counter for accumulated # timesteps,micro_pumas_cam.F90: line 741,,,counter_for_accumulated_number_of_timesteps_of_nonzero_liquid_water_path,,,,,diagnostic; not in GSL meta file,,,, +pbuf_ACPRECL,accumulated precip,micro_pumas_cam.F90: line 739,,,accumulated_stratiform_precipitation_across_timesteps_with_nonzero_liquid_water_path,,,,,diagnostic; not in GSL meta file,,,, +pbuf_AIST,Ice stratiform cloud fraction,clubb_intr:F90: 1357,frac,,stratiform_cloud_ice_area_fraction,,,,,,,,, +pbuf_ALST,Liquid stratiform cloud fraction,clubb_intr:F90: 1356,frac,,stratiform_cloud_liquid_area_fraction,,,,,,,,, +pbuf_AST,Stratiform cloud fraction,clubb_intr.F90: 1355,frac,,stratiform_cloud_area_fraction,,,,,,,,, +pbuf_BERGSO,Conversion of cloud water to snow from bergeron,micro_pumas_cam.F90: line 977,,,mixing_ratio_wrt_to_moist_air_and_condensed_water_tendency_of_cloud_liquid_water_to_snow_due_to_vapor_deposition,,,,,diagnostic; not in GSL meta file,,,, +pbuf_CC_T,tlat: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2390,,,tendency_of_air_temperature_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_ni,niten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2395,,,tendency_of_cloud_ice_number_concentration_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_nl,nlten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2394,,,tendency_of_cloud_liquid_water_number_concentration_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_qi,qiten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2392,,,tendency_of_cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_ql,qcten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2393,,,tendency_of_cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_qlst,"qcten/max(0.01_r8,alst_mic(:ncol,top_lev:pver)): Microphysical tendencies for use in the macrophysics at the next time step",micro_pumas_cam.F90: line 2396,,,tendency_of_incloud_cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CC_qv,qvlat: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2391,,,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, +pbuf_CFC11,,,,,,,,,,units: ask chemists,,,, +pbuf_CFC12,,,,,,,,,,units: ask chemists,,,, +pbuf_CH4,,,,,,,,,,units: ask chemists,,,, +pbuf_CLD,Total cloud fraction,micro_pumas_cam.F90: line 1604,frac,X,cloud_area_fraction,X,!,"""in_atmosphere_layer"" is implied - should be changed to ""cloud_area_fraction""",,,,,, +pbuf_CLDBOT,Vertical index of cloud base,convect_diagnostics.F90: line 85,index,X,vertical_index_at_cloud_base_for_all_convection,X,,,,,,,, +pbuf_CLDFGRAU,Cloud fraction for liquid+graupel,micro_pumas_cam.F90: line 1611,frac,X,liquid_plus_graupel_stratiform_cloud_area_fraction,X,,,,,,,, +pbuf_CLDFSNOW,Cloud fraction for liquid+snow,micro_pumas_cam.F90: line 1608,frac,X,liquid_plus_snow_stratiform_cloud_area_fraction,X,,,,,,,, +pbuf_CLDICEINI,"state%q(:ncol,:pver,ixcldice) from cnst_get_index('CLDICE')",physpkg.F90: line 2617,kg kg-1,X,cloud_ice_mixing_ratio_wrt_moist_air_before_physics,X,,,,,,,, +pbuf_CLDLIQINI,"state%q(:ncol,:pver,ixcldliq) from cnst_get_index('CLDLIQ')",physpkg.F90: line 2616,kg kg-1,X,cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_before_physics,X,,,,,,,, +pbuf_CLDO, Old cloud fraction,micro_pumas_cam.F90: line 1463,frac,X,cloud_area_fraction_on_previous_timestep,X,,,,,,,, +pbuf_CLDTOP,Vertical index of cloud top,convect_diagnostics: line 84,index,X,vertical_index_at_cloud_top_for_all_convection,X,,,,,,,, +pbuf_CLOUD_FRAC, Cloud fraction (thermodynamic levels),clubb_intr.F90: line 2175,frac,X,stratiform_cloud_area_fraction_due_to_clubb,X,,,,,,,, +pbuf_CMELIQ,Rate of cond-evap of liq within the cloud,clubb_intr.F90: line 1623,kg kg-1 s-1,X,stratiform_cloud_condensation_minus_evaporation,X,,,,,,,, +pbuf_CMFMC_DP,Convection mass flux from ZM deep,zm_conv_intr.F90: line 301,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_deep_convection,X,,,,,,,, +pbuf_CMFMC_SH,Shallow convective mass flux,macrop_driver.F90: line 481,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_shallow_convection,X,,,,,,,, +pbuf_CO2,,,,,,,,,,units: ask chemists,,,, +pbuf_CONCLD,Convective cloud cover,clubb_intr.F90: line 1622,frac,X,convective_cloud_area_fraction,X,X,,,,,,, +pbuf_CV_REFFICE,convective cloud ice effective radius,cam_dev/micro_pumas_cam.F90: line 1127,micron,,,,,,,cosp thing; not in GSL meta file,,,, +pbuf_CV_REFFLIQ,convective cloud liq effective radius,cam_dev/micro_pumas_cam.F90: line 1126,micron,,,,,,,cosp thing; not in GSL meta file,,,, +pbuf_DEGRAU, Graupel effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 658,m,X,effective_diameter_of_stratiform_cloud_graupel_particle_for_radiation,,,,,from m_micro.meta: cldeffg [radius],,,, +pbuf_DEI, Mitchell ice effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 638,micron,X,effective_diameter_of_stratiform_cloud_ice_particle_for_radiation,,,,,from m_micro.meta: cldeffi [radius],,,, +pbuf_DES,Snow effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 650,micron,X,effective_diameter_of_stratiform_snow_particle _for_radiation,,,,,from m_micro.meta: cldeffs [radius],,,, +pbuf_DGNUM,"unactivated particles, dry",modal_aero_data.F90: line 777,,,,,,,,ask chemists,,,, +pbuf_DGNUMWET,"unactivated particles, wet at grid-cell ambient RH",modal_aero_data.F90: line 779,,,,,,,,ask chemists,,,, +pbuf_DIFZM,Detrained ice water from ZM convection,zm_conv_intr.F90: line 327,kg kg-1 s-1,X,detrainment_of_cloud_ice_due_to_deep_convection,X,,,,,,,, +pbuf_DLFZM,Detrained liquid water from ZM convection,zm_conv_intr.F90: line 328,kg kg-1 s-1,X,detrainment_of_cloud_liquid_due_to_deep_convection,X,,,,,,,, +pbuf_DP_CLDICE, deep gmb cloud ice water,cosp_simulator_intr.F90: line 1432,kg kg-1,X,,,,,,,,,, +pbuf_DP_CLDLIQ,deep gbm cloud liquid water,cosp_simulator_intr.F90: line 1431,kg kg-1,X,,,,,,,,,, +pbuf_DP_FLXPRC,deep interface gbm flux_convective_cloud_rain+snow,cosp_simulator_intr.F90: line 1415,kg m-2 s-1,X,precipitation_mass_flux_at_interface_due_to_deep_convection,X,,"ask NOAA about precipitation = ""all phases of precipitation""",,,,,, +pbuf_DP_FLXSNW,deep interface gbm flux_convective_cloud_snow,cosp_simulator_intr.F90: line1414,kg m-2 s-1,X,frozen_precipitation_mass_flux_at_interface_due_to_deep_convection,X,,,,,,,, +pbuf_DP_FRAC,Deep convective cloud fraction,conv_water.F90: line 219,frac,X,cloud_area_fraction_due_to_deep_convection,X,,,,,,,, +pbuf_DQCORE,Water vapor tendency due to dynamical core,check_energy.F90: line 207,kg kg-1 s-1,X,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_dynamics,X,,CCPP may need to handle varying standard names dependent on host model configuration (i.e. dycore),,,,,, +pbuf_DRYMASS,single-particle-mean dry mass,modal_aero_calcsize: line 1421,kg,,,,,,,ask chemists,,,, +pbuf_DRYRAD,dry volume mean radius of aerosol,modal_aero_calcsize: line 1420,m,,,,,,,ask chemists,,,, +pbuf_DRYVOL, single-particle-mean dry volume,modal_aero_calcsize: line 1419,m3,,,,,,,ask chemists,,,, +pbuf_DTCORE,T tendency due to dynamical core,check_energy.F90: line 206,K s-1,X,tendency_of_air_temperature_due_to_dynamics,X,,,,,,,, +pbuf_DUCORE,,check_energy.F90,m s-2,X,tendency_of_eastward_wind_due_to_dynamics,X,,,,,,,, +pbuf_DVCORE,,check_energy.F90,m s-2,X,tendency_of_northward_wind_due_to_dynamics,X,,,,,,,, +pbuf_FICE,Fractional ice content within cloud,cam_dev/micro_pumas_cam.F90: line 965,frac,X,mass_fraction_of_ice_content_within_stratiform_cloud,,,,,not in GSL file; qlcn_i is convective version,,,, +pbuf_FLNS,Clearsky net longwave flux at surface,rrtmg/radiation.F90 : line 581,W m-2,X,,,,,,,,,, +pbuf_FLNT,Net longwave flux at top of model,rrtmg/radiation.F90 : line 560,W m-2,X,,,,,,,,,, +pbuf_FRACIS,fraction of transported species that are insoluble,modal_aero/aero_model.F90: line 1066,frac,,fraction_of_water_insoluble_convectively_transported_species,X,,,,ask chemists,,,, +pbuf_FRZCNT,Number tendency due to contact freezing,pumas/micro_pumas_v1.F90:line 781,cm-3,,ice_number_concentration_tendency_due_to_contact_freezing,,,,,not in GSL file,ask andrew about units and whether tendency,,, +pbuf_FRZDEP,Number tendency due to deposition nucleation,pumas/micro_pumas_v1.F90:line 782,cm-3,,ice_number_concentration_tendency_due_to_deposition_nucleation,,,,,not in GSL file,ask andrew about units and whether tendency,,, +pbuf_FRZIMM,Number tendency due to immersion freezing,pumas/micro{pumas_v1.F90: line 780,cm-3,,ice_number_concentration_tendency_due_to_immersion_freezing,,,,,not in GSL file,ask andrew about units and whether tendency,,, +pbuf_FSDS,Downwelling solar flux at surface,rrtmg/radiation.F90: line 516,W m-2,X,,,,,,,,,, +pbuf_FSNS,Net solar flux at surface,rrtmg/radiaton.F90: line 511,W m-2,X,,,,,,,,,, +pbuf_FSNT,Net solar flux at top of model,rrtmg/radiation.F90: line 476,W m-2,X,,,,,,,,,, +pbuf_HYGRO, volume-weighted mean hygroscopicity,chemistry/utils/modal_aero_calcsize.F90,unitless?????,,,,,,,units: ask chemists,,,, +pbuf_ICGRAUWP,In-cloud snow water path,cam_dev/micro_pumas_cam.F90: line 1625,kg m-2,X,stratiform_in_cloud_graupel_water_path,,,Snapshot name is wrong,,not in GSL file,,,, +pbuf_ICIWP,radiation input: In-cloud ice water path,radiation_data.F90: line 363,kg m-2,X,,,,,,,,,, +pbuf_ICIWPST,Stratiform only in cloud ice water path for radiation,cam_dev/micro_pumas.F90: line 645,kg m-2,X,stratiform_in_cloud_ice_water_path_for_radiation,,,,,not in GSL file,,,, +pbuf_ICLWP, In cloud liquid water path for radiation,cloud_diagnostics.F90: line 80,kg m-2,X,,,,,,,,,, +pbuf_ICLWPST,Stratiform in cloud liquid water path for radiation,cam_dev/micro_pumas.F90: line 647,kg m-2,X,stratiform_in_cloud_liquid_water_path_for_radiation,,,,,not in GSL file,,,, +pbuf_ICSWP,radiation input: In-cloud snow water path,radiation_data.F90: line 367,kg m-2,X,,,,,,,,,, +pbuf_ICWMRDP,Deep Convection in-cloud water mixing ratio,convect_deep.F90: line 165,kg kg-1,X,in_cloud_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_deep_convection,X,,,,,,,, +pbuf_ICWMRSH,Shallow Convection in-cloud water mixing ratio,convect_shallow.F90: line 231,kg kg-1,X,in_cloud_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_shallow_convection,,,,,,,,, +pbuf_ISS_FRAC,Cloud fraction of ice clouds,clubb_intr.F90: line 2210,frac,X,ice_supersaturated_cloud_area_fraction,,,,,,,,, +pbuf_LAMBDAC,radiation input: slope of droplet distribution for optics (radiation),radiation_data.F90: line 361,1,X,,,,,,,,,, +pbuf_LANDM,,cam_dev/physpkg.F90,frac,X,smoothed_land_fraction,,,,,,,,, +pbuf_LS_FLXPRC,MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces,micro_pumas_cam.F90: line 1554,kg m-2 s-1,X, stratiform_rain_and_snow_flux_at_interface,,,,,,,,, +pbuf_LS_FLXSNW,MG grid-box mean flux_large_scale_cloud_snow at interfaces,micro_pumas_cam.F90: line 1555,kg m-2 s-1,X,stratiform_snow_flux_at_interface,,,,,,,,, +pbuf_LS_MRPRC,MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces,micro_pumas_cam.F90: line 1556,kg kg-1,X,stratiform_mixing_ratio_of_snow_wrt_moist_air_and_condensed_water_at_interface,,,,,,,,, +pbuf_LS_MRSNW,MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces,micro_pumas_cam.F90: line 1557,kg kg-1,X,stratiform_mixing_ratio_of_rain_and_snow_wrt_moist_air_and_condensed_water_at_interface,,,,,,,,, +pbuf_LS_REFFRAIN,MG diagnostic rain effective radius (um),micro_pumas_cam.F90: line 1558,micron,X,diagnostic_rain_effective_radius_due_to_microphysics,,,,,,,,, +pbuf_LS_REFFSNOW,MG diagnostic snow effective radius (um),micro_pumas_cam.F90: line 1559,micron,X,diagnostic_snow_effective_radius_due_to_microphysics,,,,,,,,, +pbuf_MU,Size distribution shape parameter for radiation,micro_pumas_cam.F90: line 1470,1,X,size_distribution_shape_parameter_for_microphysics,,,,,,,,, +pbuf_N2O,,pbuf_get_field call in rad_constituents.F90: line 487,,,,,,,,,,,, +pbuf_NAAI,ice nucleation number,micro_pumas_cam.F90: line 1443,kg-1,CONTINUE UNITS HERE!!!!!!!,number_of_activated_ice_nuclei,,,,,,,,, +pbuf_NAAI_HOM,ice nucleation number (homogeneous),micro_pumas_cam.F90: line 1444,kg-1,,number_of_activated_ice_nuclei_due_to_homogenous_freezing,,,,,,,,, +pbuf_NACON,"number in each dust bin, for contact freezing (from microp_aero_ts)",micro_pumas_v1.F90: line 695,m-3,,dust_number_concetnration_by_size_bin_for_contact_freezing,,,,,,,,, +pbuf_NAER, aerosol number MR (bounded!),model_aero_calcsize.F90: line 1423,kg-air-1?,,,,,,,,,,, +pbuf_NEVAPR,Evaporation of total precipitation (rain + snow),micro_pumas_cam.F90: line 1464,,,precipitation_evaporation_due_to_microphysics,,,,,,,,, +pbuf_NEVAPR_DPCU,Evaporation of deep convective precipitation,convect_deep.F90: line 459,,,precipitation_evaporation_due_to_deep_convection,,,,,,,,, +pbuf_NEVAPR_SHCU,Evaporation of shallow convective precipitation >= 0,convect_shallow.F90: line 460,,,precipitation_evaporation_due_to_shallow_convection,,,,,,,,, +pbuf_NPCCN,liquid activation number tendency,micro_pumas_cam.F90: line 1445,,,liquid_drop_activation_number_tendecy,,,,,,,,, +pbuf_O2,,pbuf_get_field call in rad_constituents.F90: line 487,,,,,,,,,,,, +pbuf_PRAIN,Total precipitation (rain + snow),micro_pumas_cam.F90: line 1468,,,precipitation_due_to_microphysics,,,,,,,,, +pbuf_PREC_DP,total precipitation,convect_deep.F90: line 198,m s-1,X,lwe_precipitation_rate_at_surface_due_to_deep_convection,X,,convective_precipitation_rate(iap_dom),,,,,, +pbuf_PREC_PCW,Sfc flux of precip from microphysics,micro_pumas_cam.F90: line 1456,m s-1,,lwe_stratiform_precipitation_rate_at_surface,,,,,,,,, +pbuf_PREC_SED,Surface flux of total cloud water from sedimentation,micro_pumas_cam.F90: line 1454,,,stratiform_cloud_water_surface_flux_due_to_sedimentation,,,,,,,,, +pbuf_PREC_SH,Shallow convective precipitation (rain+snow) rate at surface,convect_shallow.F90: line 407,,,,,,,,,,,, +pbuf_PREC_STR,[Total] Sfc flux of precip from stratiform,micro_pumas_cam.F90: line 1452,m s-1,,stratiform_rain_and_snow_surface_flux_due_to_sedimentation,,,,,,,,, +pbuf_PRER_EVAP,precipitation evaporation rate,micro_pumas_cam.F90: line 1465,,,precipitation_evaporation_rate_due_to_microphysics,,,,,,,,, +pbuf_PSL,sea level pressure,cam_diagnostics.F90: line 967,Pa,,,,,,,,,,, +pbuf_QAERWAT,aerosol water,modal_aer_opt.F90: line 500,g g-1,,,,,,,,,,, +pbuf_QINI,,addfld call in cam/physpkg.F90: line 207,,,,,,,,,,,, +pbuf_QIST,Physical in-stratus IWC,clubb_intr.F90: line 2336,kg kg-1,,stratiform_cloud_ice_water_content,X,,,,,,,, +pbuf_QLST,Physical in-stratus LWC,clubb_intr.F90: line 2335,kg kg-1,,stratiform_cloud_liquid_water_content,X,,,,,,,, +pbuf_QME,Net micro_pumas_cam condensation rate,micro_pumas_cam.F90: line 2399,,,net_condensation_rate_due_to_microphysics,,,,,,,,, +pbuf_QRL,longwave radiative heating rate,rrtmg/radiation.F90: line 794,K s-1,,,,,,,,,,, +pbuf_QRS,shortwave radiative heating rate,rrtmg/radiation.F90: line 793,K s-1,,,,,,,,,,, +pbuf_QSATFAC,Subgrid cloud water saturation scaling factor,micro_pumas_cam.F90: line 1460,,,subgrid_cloud_water_saturation_scaling_factor_for_microphysics,,,,,,,,, +pbuf_RAD_CLUBB,,addfld call in cam/clubb_intr.F90: line 514,,,,,,,,,,,, +pbuf_RATE1_CW2PR_ST,1st order rate for direct conversion of strat. cloud water to precip,micro_pumas_cam.F90: line 1569,s-1,,direct_conversion_rate_of_stratiform_cloud_water_to_precipitation_for_scavenging,,,,,,,,, +pbuf_RCM,CLUBB cloud water mixing ratio ,clubb_intr.F90: line 2326,kg kg-1,,cloud_water_mixing_ratio_wrt_dry_air_due_to_clubb,X,,,,,,,, +pbuf_RC_COEF,Coef. of X'r_c' in Eq. (34) (thermodynamic levels),clubb_intr.F90: line 2318,,,factor_converting_from_liquid_cloud_water_moment_to_component_of_virtual_potential_temperature_moment,X,,,,,,,, +pbuf_REI,Ice effective drop size,micro_pumas_cam.F90: line 1597,micron,,effective_radius_of_stratiform_cloud_ice_particle,X,X,,,from m_micro.meta file: cldreffi,,,, +pbuf_REL,Liquid effective drop radius,micro_pumas_cam.F90: line 1596,micron,,effective_radius_of_stratiform_cloud_liquid_water_particle,X,X,,,from m_micro.meta file: cldreffl,,,, +pbuf_RELVAR,relative variance of cloud water,micro_pumas_cam.F90: line 1417,,,relative_variance_of_subgrid_cloud_condensate_distribution,X,X,,,from m_micro.meta file: mg_qcvar,,,, +pbuf_RLIQBC,tphysbc reserve liquid,cam_dev/physpkg.F90: line 2495,,,,,,,,,,,, +pbuf_RNDST,radius of 4 dust bins for contact freezing,microp_aero.F90: line 490,,,,,,,,,,,, +pbuf_RPRDDP,dq/dt due to deep convective rainout,convect_shallow.F90: line 458,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection_excluding_subcloud_evaporation,X,,,,,,,, +pbuf_RPRDSH,dq/dt due to deep and shallow convective rainout,convect_shallow.F90: line 459,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_shallow_convection_excluding_subcloud_evaporation,X,,,,,,,, +pbuf_RPRDTOT,RPRDDP + RPRDSH,convect_shallow.F90: line 719,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_convection_excluding_subcloud_evaporation,X,,,,,,,, +pbuf_RTM,mean moisture mixing ratio,clubb_intr.F90: line 2325,,,sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_RTP2_nadv,moisture variance,clubb_intr.F90: line 2294,kg2 kg-2,,advected_variance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_RTP3,moisture 3rd order,clubb_intr.F90: line 2396,kg3 kg-3,,third_moment_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_RTPTHLP_nadv,covariance of thetal and qt,clubb_intr.F90: line 2297,kg kg-1 K-1,,covariance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_liquid_water_potential_temperature,X,,,,,,,, +pbuf_RTPTHVP,r_t'th_v' (momentum levels),clubb_intr.F90: line 2327,kg kg-1 K-1,,covariance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_virtual_potential_temperature,X,,,,,,,, +pbuf_SADICE,Ice surface area density,micro_pumas_cam.F90: line 1598,cm2 cm-3,,ice_surface_area_density_for_microphysics,,,,,,,,, +pbuf_SADSNOW,Snow surface area density,micro_pumas_cam.F90: line 1599,cm2 cm-3,,snow_surface_area_density_for_microphysics,,,,,,,,, +pbuf_SGH,standard deviation of orography,gw_drag.F90: line 1330,m,,,,,,,,,,, +pbuf_SGH30,standard deviation of subgrid topographic height at 30 s horizontal area,unicon.F90: line 565,m,,,,,,,,,,, +pbuf_SH_CLDICE1,shallow convection gbx ice cld mixing ratio for COSP,conv_water.F90: line 226,,,,,,,,,,,, +pbuf_SH_CLDLIQ1,shallow convection gbx liq cld mixing ratio for COSP,conv_water.F90: line 225,,,,,,,,,,,, +pbuf_SH_FRAC,shallow convection cloud fraction,conv_water.F90: line 218,,,,,,,,,,,, +pbuf_SNOW_DP,snow from ZM convection,convect_deep.F90: line 206,m s-1,,lwe_frozen_precipitation_rate_at_surface_due_to_deep_convection,X,,"lwe_convective_snowfall_rate (iap_dom), lwe_snowfall_rate (git repo)",,,,,, +pbuf_SNOW_PCW,Sfc flux of snow from microphysics,micro_pumas_cam.F90: line 1408,m s-1,,lwe_snow_precipitation_rate_at_surface_due_to_microphysics,,,,,,,,, +pbuf_SNOW_SED,Surface flux of cloud ice from sedimentation,micro_pumas_cam.F90: line 1406,,,lwe_cloud_ice_sedimentation_rate_at_surface_due_to_microphysics,,,,,,,,, +pbuf_SNOW_SH,shallow convective snow rate at surface,convect_shallow.F90: line 408,m s-1,,,,,,,,,,, +pbuf_SNOW_STR,[Total] Sfc flux of snow from stratiform,micro_pumas_cam.F90: line 1404,m s-1,,lwe_snow_and_cloud_ice_precipitation_rate_at_surface_due_to_microphysics ,,,,,,,,, +pbuf_SO4DRYVOL,single-particle-mean so4 dry volume,modal_aero_calcsize.F90: line 1431,m3,,,,,,,,,,, +pbuf_SRFOZONE,surface ozone,chemistry.F90: line 817,,,,,,,,,,,, +pbuf_TEOUT,total energy for global fixer in next timestep,physpkg.F90: line 1856,J m-2,,,,,,,,,,, +pbuf_THLM,mean temperature,clubb_intr.F90: line 2324,K,,liquid_water_potential_temperature,X,,,,,,,, +pbuf_THLP2_nadv,temperature variance,clubb_intr.F90: line 2295,K2,,advected_variance_of_liquid_water_potential_temperature,X,,,,,,,, +pbuf_THLP3,temperature third order,clubb_intr.F90: line 2297,K3,,third_moment_of_liquid_water_potential_temperature,X,,,,,,,, +pbuf_THLPTHVP,th_l'th_v' (momentum levels),clubb_intr.F90: line 2307,K2,,covariance_of_liquid_water_potential_temperature_and_virtual_potential_temperature,X,,,,,,,, +pbuf_TREFMNAV,daily minimum reference temperature,cam_diagnostics.F90: line 1815,K,,,,,,,,,,, +pbuf_TREFMXAV,daily maximum reference temperature,cam_diagnostics.F90: line 1816,K,,,,,,,,,,, +pbuf_T_TTEND,temperature from previous timestep?,addfld call in cam_diagnostics: line 154,,,,,,,,,,,, +pbuff_T_UTEND,u wind from previous timestep?,addfld call in cam_diagnostics: line 155,,,,,,,,,,,, +pbuf_T_VTEND,v wind from previous timestep?,addfld call in cam_diagnostics: line 156,,,,,,,,,,,, +pbuf_UM,mean east-west wind,clubb_intr.F90: line 2328,m s-1,,eastward_wind,X,,,,,,,, +pbuf_UP2_nadv,east-west wind variance,clubb_intr.F90: line 2298,m2 s-2,,advected_variance_of_eastward_wind,X,,,,,,,, +pbuf_UP3,east-west wind 3rd order,clubb_intr.F90: line 2300,m3 s-3,,third_moment_of_eastward_wind,X,,,,,,,, +pbuf_UPRCP,< u' r_c' > (momentum levels),clubb_intr.F90: line 2316,,,covariance_of_eastward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_UPWP,east-west momentum flux,clubb_intr.F90: line 2302,m2 s-2,,covariance_of_eastward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_vertical_velocity,X,,,,,,,, +pbuf_VM,mean north-south wind,clubb_intr.F90: line 2329,m s-1,,northward_wind,X,,,,,,,, +pbuf_VOLC_MMR1,prescribed volcanic aerosol dry mass mixing ratio in Mode 1,prescribed_strataero.F90: line 272,kg kg-1,,,,,,,,,,, +pbuf_VOLC_MMR2,prescribed volcanic aerosol dry mass mixing ratio in Mode 2,prescribed_strataero.F90: line 273,kg kg-1,,,,,,,,,,, +pbuf_VOLC_MM3,prescribed volcanic aerosol dry mass mixing ratio in Mode 3,prescribed_strataero.F90: line 274,kg kg-1,,,,,,,,,,, +pbuf_VOLC_RAD_GEOM1,volcanic aerosol geometric-mode radius in Mode 1,prescribed_strataero.F90: line 275,m,,,,,,,,,,, +pbuf_VOLC_RAD_GEOM2,volcanic aerosol geometric-mode radius in Mode 2,prescribed_strataero.F90: line 276,m,,,,,,,,,,, +pbuf_VOLC_RAD_GEOM3,volcanic aerosol geometric-mode radius in Mode 3,prescribed_strataero.F90: line 277,m,,,,,,,,,,, +pbuf_VOLC_SAD,stratospheric aerosol surface area density,prescribed_strataero.F90: line 291,cm2 cm-3,,,,,,,,,,, +pbuf_VP2_nadv,north-sound wind variance,clubb_intr.F90: line 2299,m2 s-2,,advected_variance_of_northward_wind,,,,,,,,, +pbuf_VP3,north-south wind 3rd order,clubb_intr.F90: line 2301,m3 s-3,,third_order_moment_of_northward_wind,,,,,,,,, +pbuf_VPRCP,< v' r_c' > (momentum levels),clubb_intr.F90: line 2317,,,covariance_of_northward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air,,,,,,,,, +pbuf_VPWP,north-south momentum flux,clubb_intr.F90: line 2303,m2 s-2,,covariance_of_northward_wind_and_vertical_velocity,,,,,,,,, +pbuf_WETDENS_AP,,modal_aero_wateruptake.F90: line 41,,,,,,,,,,,, +pbuf_WP2RTP,w'^2 th_v' (thermodynamic levels),clubb_intr.F90: line 2314,,,third_order_moment_of_variance_of_vertical_velocity_and_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_WP2THLP,w'^2 thl' (thermodynamic levels),clubb_intr.F90: line 2315,,,third_order_moment_of_variance_of_vertical_velocity_and_liquid_water_potential_temperature,X,,,,,,,, +pbuf_WP2THVP,second order buoyancy term,clubb_intr.F90: line 2305,m2 s-2 K,,third_order_moment_of_variance_of_vertical_velocity_and_virtual_potential_temperature,X,,,,,,,, +pbuf_WP2UP2,w'^2 u'^2 (momentum levels),clubb_intr.F90: 2322,,,fourth_order_moment_of_variance_of_vertical_velocity_and_variance_of_eastward_wind,X,,,,,,,, +pbuf_WP2VP2,w'^2 v'^2 (momentum levels),clubb_intr.F90: 2323,,,fourth_order_moment_of_variance_of_vertical_velocity_and_variance_of_northward_wind,X,,,,,,,, +pbuf_WP2_nadv,vertical velocity variance,clubb_intr.F90: 2283,m2 s-2,,advected_variance_of_vertical_velocity,X,,,,,,,, +pbuf_WP3_nadv,third moment of vertical velocity,clubb_intr.F90: 2284,m3 s-3,,advected_third_order_moment_of_vertical_velocity,X,,,,,,,, +pbuf_WP4,w'^4 (momentum levels),clubb_intr.F90: line 2319,,,fourth_order_moment_of_vertical_velocity,X,,,,,,,, +pbuf_WPRTP_nadv,turbulent flux of moisture,clubb_intr.F90: line 2292,m s-1 kg kg-1,,advected_covariance_of_vertical_velocity_and_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, +pbuf_WPTHLP_nadv,turbulent flux of thetal,clubb_intr.F90: line 2291,m s-1 K,,advected_covariance_of_vertical_velocity_and_liquid_water_potential_temperature,X,,,,,,,, +pbuf_WPTHVP,Buoyancy Flux,clubb_intr.F90: line 1686,W m-2,,advected_covariance_of_vertical_velocity_and_virtual_potential_temperature,X,,,,,,,, +pbuf_WPUP2,w'u'^2 (thermodynamic levels),clubb_intr.F90: line 2320,,,third_order_moment_of_vertical_velocity_and_variance_of_eastward_wind,X,,,,,,,, +pbuf_WPVP2,w'v^2 (thermodynamic levels),clubb_intr.F90: line 2321,,,third_order_moment_of_vertical_velocity_and_variance_of_northward_wind,X,,,,,,,, +pbuf_WSEDL,Sedimentation velocity of liquid stratus cloud droplet,micro_pumas_cam.F90: line 1571,m s-1,,,,,,,,,,, +pbuf_ZM_DP,Delta pressure between interfaces,modal_aero_convproc.F90: line 556,,hPa,pressure_thickness_for_deep_convection_for_convective_columns,X,,"pressure_thickness_in_hPa (iap_dom) , air_pressure_thickness (in github repo)",X,,,,, +pbuf_ZM_DSUBCLD,Delta pressure from cloud base to sfc,modal_aero_convproc.F90: line 557,,hPa,pressure_thickness_for_subcloud_layer_for_deep_convection_for_convective_columns,X,,subcloud_pressure_thicknes_in_hPa (iap_dom),X,,,,, +pbuf_ZM_DU,Mass detrain rate from updraft,modal_aero_convproc.F90: line 552,s-1,X,atmosphere_detrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,^ (Need to add new CCPP dimension for all convective columns),,,,, +pbuf_ZM_ED,Mass entrain rate into downdraft,modal_aero_convproc.F90: line 554,s-1,X,atmosphere_downdraft_entrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,|,,,,, +pbuf_ZM_EU,Mass entrain rate into updraft,modal_aero_convproc.F90: line 553,s-1,X,atmosphere_updraft_entrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,ask about removing gather,,,,, +pbuf_ZM_IDEEP,Gathering array,modal_aero_convproc.F90: line 561,index,X,horizontal_index_of_convective_columns_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,"(Rich first, then Francis)",,,,, +pbuf_ZM_JT,wg top level index of deep cumulus convection,zm_conv.F90: line 353,index,X,vertical_index_at_top_of_deep_convection_for_convective_columns,X,,Clean-up - skip gather,|,,,,, +pbuf_ZM_MAXG,wg gather values of maxi,zm_conv.F90: line 354,index,X,vertical_index_of_deep_convection_launch_level_for_convective_columns,X,,Clean-up - skip gather,v,,,,, +pbuf_ZM_MU,Updraft mass flux (positive),modal_aero_convproc.F90: line 550,hPa s-1,X,atmosphere_updraft_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,X,,,,, +pbuf_ZM_MD,Downdraft mass flux (negative),modal_aero_convproc.F90: line 551,hPa s-1,X,atmosphere_downdraft_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,X,,,,, +pbuf_ZTODT,timestep to send to SILHS,clubb_intr.F90: line 2327,s,X,timestep_for_physics,X,,,,,,,, +pbuf_am_evp_st,Area over which precip evaporates,micro_pumas_cam.F90: line 1448,,,microphysics_precipitation_evaporation_area,,,,,,,,, +pbuf_bc_c1,bc_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_bc_c4,bc_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_dragblj,Beljaars SGO form drag profile,vertical_diffusion.F90: line 729,s-1,,turbulent_orographic_form_drag_coefficent,,,,,,,,, +pbuf_dst_c1,dst_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_dst_c2,dst_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_dst_c3,dst_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_evprain_st,Evaporation rate of stratiform rain,micro_pumas_cam.F90: line 1400,kg kg-1 s-1,,stratiform_rain_evaporation_rate,,,,,,,,, +pbuf_evpsnow_st,Evaporation rate of stratiform snow,micro_pumas_cam.F90: line 1401,kg kg-1 s-1,,stratiform_snow_evaporation_rate,,,,,,,,, +pbuf_ksrftms,Turbulent mountain stress surface drag coefficient,vertical_diffusion.F90: line 723,kg s-1 m-2,,turbulent_orographic_form_drag_coefficent_at_surface,,,,,,,,, +pbuf_kvh,Eddy diffusivity for heat,vertical_diffusion.F90: line 737,m2 s-1,,eddy_heat_diffusivity_at_interface,,,,,,,,, +pbuf_kvm,Eddy diffusivity for momentum,vertical_diffusion.F90: line 738,m2 s-1,,eddy_momentum_diffusivity_at_interface,,,,,,,,, +pbuf_kvt,Molecular kinematic conductivity for temperature,vertical_diffusion.F90: line 735,m2 s-1,,molecular_kinematic_temperature_conductivity_at_interface,,,,,,,,, +pbuf_ncl_c1,ncl_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_ncl_c2,ncl_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_ncl_c3,ncl_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_num_c1,num_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_num_c2,num_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_num_c3,num_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_num_c4,num_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_ozone,ozone,prescribed_ozone.F90: line 53,,,,,,,,,,,, +pbuf_pblh,planetary boundary layer height,clubb_intr.F90: line 2340,m,X,atmosphere_boundary_layer_thickness,X,X,,,,,,, +pbuf_pdf_zm_mixt_frac,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,weight_for_pdfs_in_double_gaussian,X,,,,,,,, +pbuf_pdf_zm_var_w_1,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,variance_of_vertical_velocity_in_first_gaussian_pdf,X,,,,,,,, +pbuf_pdf_zm_var_w_2,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,variance_of_vertical_velocity_in_second_gaussian_pdf,X,,,,,,,, +pbuf_pdf_zm_w_1,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,vertical_velocity_in_first_gaussian_pdf_at_interface,X,,,,,,,, +pbuf_pdf_zm_w_2,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,vertical_velocity_in_second_gaussian_pdf_at_interface,X,,,,,,,, +pbuf_pom_c1,pom_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_pom_c4,pom_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_qpert,PBL perturbation specific humidity,convect_shallow.F90: line 416,kg kg-1,,convective_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_perturbation_at_surface,,,,,,,,, +pbuf_rtp2_mc_zt,SILHS covariance contributions / rtp2 forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, +pbuf_rtpthlp_mc_zt,SILHS covariance contributions / rtpthlp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, +pbuf_smaw,Normalized Galperin instability function ( 0<= <=4.964 and 1 at neutral ),turbulence_type_at_interface,,,normalized_galperin_stability_function_for_momentum_at_interfaces,,,,,,,,, +pbuf_so4_c1,so4_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_so4_c2,so4_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_so4_c3,so4_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_soa_c1,soa_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_soa_c2,soa_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, +pbuf_taubljx,U component of turbulent mountain stress,vertical_diffusion.F90: line 730,N m-2,,eastward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, +pbuf_taubljy,V component of turbulent mountain stress,vertical_diffusion.F90: line 731,N m-2,,northward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, +pbuf_tauresx,Reserved surface stress at previous time step,diffusion_solver.F90: line 237,,,eastward_reserved_stress_at_surface_on_previous_timestep,,,,,,,,, +pbuf_tauresy,Reserved surface stress at current time step,diffusion_solver.F90: line 238,,,northward_reserved_stress_at_surface_on_previous_timestep,,,,,,,,, +pbuf_tautmsx,Implicit zonal turbulent mountain surface stress,diffusion_solver.F90: line 238,N m-2,,eastward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, +pbuf_tautmsy,Implicit meridional turbulent mountain surface stress,diffusion_solver.F90: line 239,N m-2,,northward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, +pbuf_thlp2_mc_zt,SILHS covariance contributions / thlp2 forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, +pbuf_tke,Turbulent kinetic energy,vertical_diffusion.F90: line 712,m2 s-2,,turbulent_kinetic_energy_at_interface,,,,,,,,, +pbuf_tpert,Perturbation temperature (eddies in PBL),vertical_diffusion.F90: line 477,K,X,convective_temperature_perturbation_due_to_pbl_eddies,X,,,,,,,, +pbuf_turbtype,Turbulent interface types,vertical_diffusion.F90: line 713,unitless,,turbulence_type_at_interface,,,,,,,,, +pbuf_wprtp_mc_zt,SILHS covariance contributions / wprtp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, +pbuf_wpthlp_mc_zt,SILHS covariance contributions / wpthlp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, +STATE VARIABLES,,,,,,,,,,,,,, +state_exner,,,,,inverse_exner_function_wrt_surface_pressure,,,See issue: https://github.com/ESCOMP/CAM/issues/753,,,,,, +state_lnpint,,,,,ln_of_air_pressure_at_interface,,,ln_air_pressure_at_interface,"remove ""of""",,,,, +state_lnpintdry,,,,,ln_of_air_pressure_of_dry_air_at_interface,,,ln_air_pressure_of_dry_air_at_interface,"remove ""of""",,,,, +state_lnpmid,,,,,ln_of_air_pressure,,,ln_air_pressure,"remove ""of""",,,,, +state_lnpmiddry,,,,,ln_of_air_pressure_of_dry_air,,,ln_air_pressure_of_dry_air_at_interface,"remove ""of""",,,,, +state_omega,,,Pa s-1,,lagrangian_tendency_of_air_pressure,,X,,,,,,, +state_pdel,,,Pa,X,air_pressure_thickness,X,X,,,,,,, +state_pdeldry,,,Pa,X,air_pressure_thickness_of_dry_air,,,air_pressure_thickness_of_dry_air,"add ""air""",,,,, +state_phis,,,m2 s-2,X,surface_geopotential,X,X,,fix units! m2 m-2 => m2 s-2; use surface_geopotential,,,,, +state_pint,,,Pa,X,air_pressure_at_interface,,X,,,,,,, +state_pintdry,,,Pa,X,air_pressure_of_dry_air_at_interface,,X,,,,,,, +state_pmid,,,Pa,X,air_pressure,,X,,,,,,, +state_pmiddry,,,Pa,X,air_pressure_of_dry_air,,X,,,,,,, +state_ps,,,Pa,,surface_air_pressure,,X,,,,,,, +state_psdry,,,Pa,,surface_pressure_of_dry_air,,X,,,,,,, +state_rpdel,,,Pa-1,,reciprocal_of_air_pressure_thickness,,,reciprocal_of_air_pressure_thickness,"add ""air"" - fix units! Pa-1",,,,, +state_rpdeldry,,,Pa-1,,reciprocal_of_air_pressure_thickness_of_dry_air,,,reciprocal_of_air_pressure_thickness_of_dry_air,"add ""air"" - fix units! Pa-1",,,,, +state_s,,,J kg-1,X,dry_static_energy,,X,,,,,,, +state_t,,,K,,air_temperature,,X,,,,,,, +state_te_cur,,,,,column_integrated_total_kinetic_and_static_energy,,-,change to vertically_integrated_energies_of_current_state_in_cam?,add J m-2 units,,,,, +state_te_ini,,,,,column_integrated_total_kinetic_and_static_energy_of_initial_state,,-,change to vertically_integrated_energies_of_initial_state_in_cam?,add J m-2 units,,,,, +state_tw_cur,,,kg m-2,,column_integrated_total_water,,-,change to vertically_integrated_total_water_of_current_state,add kg m-2 units,,,,, +state_tw_ini,,,kg m-2,,column_integrated_total_water_of_initial_state,,-,vertically integrated_total_water_of_initial_state,add kg m-2 units,,,,, +state_u,,,m s-1,,eastward_wind,X,,,,,,,, +state_v,,,m s-1,,northward_wind,X,,,,,,,, +state_zi,,,m,X,geopotential_height_wrt_surface_at_interface,X,,,,,,,, +state_zm,,,m,X,geopotential_height_wrt_surface,,X,,,,,,, +TENDENCY VARIABLES,,,,,,,,,,,,,, +tend_dtdt,,,K s-1,,tendency_of_air_temperature_due_to_model_physics,,X,,,,,,, +tend_dudt,,,,,tendency_of_eastward_wind_due_to_model_physics,X,,,add m s-2 units,,,,, +tend_dvdt,,,,,tendency_of_northward_wind_due_to_model_physics,X,,,add m s-2 units,,,,, +tend_flx_net,,physics_types.F90: line 128,,,,,,,,,,,, +tend_te_tnd,cumulative boundary flux of total energy,physics_types.F90: line 130,,,,,,,,,,,, +tend_tw_tend,cumulative boundary flux of total water,physics_types.F90: line 131,,,,,,,,,,,, +ptend_u,u momentum tendency,physics_types.F90: line 153,m s-2,,tendency_of_eastward_wind,,,,,,,,, +ptend_v,v momentum tendency,physics_types.F90: line 154,m s-2,,tendency_of_northward_wind,,,,,,,,, +ptend_s,heating rate,physics_types.F90: line 152,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure,X,X,,,,,,, +ptend_hflux_srf,net heat flux at surface,physics_types.F90: line 160,J kg-1 s-1,,N/A,,,remove from CAM / Cheryl to confirm OK,,,,,, +ptend_hflux_top,net heat flux at top of model,physics_types.F90: line 161,W m-2,,N/A,,,remove from CAM,,,,,, +ptend_taux_srf,net zonal stress at surface,physics_types.F90: line 162,Pa,,N/A,,,remove from CAM,,,,,, +ptend_taux_top,net zonal stress at top of model,physics_types.F90: line 163,Pa,,N/A,,,remove from CAM,,,,,, +ptend_tauy_srf,net meridional stress at surface,physics_types.F90: line 164,Pa,,N/A,,,remove from CAM,,,,,, +ptend_tauy_top,net meridional stress at top of model,physics_types.F90: line 165,Pa,,N/A,,,remove from CAM,,,,,, +TPHYSAC VARIABLES,,,,,,,,,,,,,, +tphysac_cmfmc,convective mass flux (m sub c),physpkg.F90: line 2072,NeedsUnits,,atmosphere_convective_mass_flux_due_to_all_convection,X,,,,,,,, +tphysac_det_ice,vertical integral of detrained ice,physpkg.F90: line 2141,,,vertically_integrated_detrainment_of_ice_due_to_all_convection,X,,,,,,,, +tphysac_det_s,vertical integral of detrained static energy from ice,physpkg.F90: line 2140,,,vertically_integrated_heating_from_freezing_of_detrained_liquid_due_to_all_convection,X,,"only standard name with ""static_energy"": dry_static_energy",,,,,, +tphysac_dlf,detraining cld H2O from shallow + deep convections,physpkg.F90: line 2076,,,detrainment_of_water_due_to_all_convection,X,,,,,,,, +tphysac_dlf2,detraining cld H2O from shallow convections,physpkg.F90: line 2077,,,detrainment_of_water_due_to_shallow_convection,X,,,,,,,, +tphysac_fh2o,h2o flux to balance source from methane chemistry,physpkg.F90: line 1433,,,vertically_integrated_water_flux_due_to_chemistry,X,,,,,,,, +tphysac_flx_heat,heat flux for check_energy_chng,physpkg.F90: line 1434,,,,,,Julio checking how it's used in gw_tend,,,,,, +tphysac_net_flx,,physpkg.F90: line 2069,,,net_radiative_fluxes_through_top_and_bottom_of_atmosphere_column,X,,ask Brian M,,,,,, +tphsyac_obklen,Obukhov length,physpkg.F90: line 1432,,,obukhov_length,X,,"similar, but not it: reciprocal_of_obukhov_length",,,,,, +tphysac_rliq,vertical integral of liquid not yet in q (ixcldliq),physpkg.F90: line 2137,kg m-2 s-1,X,vertically_integrated_cloud_liquid_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, +tphysac_rliq2,vertical integral of liquid from shallow scheme,physpkg.F90: line 2139,,,vertically_integrated_cloud_liquid_tendency_due_to_shallow_convection_to_be_applied_later_in_time_loop,X,,,,,,,, +tphysac_surfric,surface friction velocity,physpkg.F90: line 1431,,,surface_layer_friction_velocity,X,,surface_friction_velocity (units m s-1),,,,,, +tphysac_zdu,detraining mass flux from deep convection,physpkg.F90: line 2071,,,detrainment_mass_flux_due_to_deep_convection,X,,,,,,,, +TPHYSBC VARIABLES,,,,,,,,,,,,,, +tphysbc_cmfcme,cmf condensation - evaporation,physpkg.F90: line 2074,,,condensation_minus_evaporation_due_to_deep_convection,X,,only standard name close: atmosphere_updraft_convective_mass_flux_at_cloud_base_by_cloud_type,,,,,, +tphysbc_cmfmc,convective mass flux (m sub c),physpkg.F90: line 2072,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_all_convection,X,,only standard name close: atmosphere_updraft_convective_mass_flux_at_cloud_base_by_cloud_type,,,,,, +tphysbc_dlf,detraining cld H2O from shallow + deep convections,physpkg.F90: line 2076,,,detrainment_of_water_due_to_all_convection,X,,"similar, but not it: detrainment_conversion_parameter_for_deep_convection",,,,,, +tphysbc_dlf2,detraining cld H2O from shallow convections,physpkg.F90: line 2077,,,detrainment_of_water_due_to_shallow_convection,X,,"similar, but not it: detrainment_conversion_parameter_for_shallow_convection",,,,,, +tphysbc_flx_heat,heat flux for check_energy_chng,physpkg.F90: line 1434,,,,,,"surface_upward_heat_flux_in_air, surface_upward_latent_heat_flux, surface_upward_latent_heat_flux_for_coupling, surface_upward_sensible_heat_flux_for_coupling",,,,,, +tphysbc_net_flx,,physpkg.F90: line 2069,,,net_radiative_fluxes_through_top_and_bottom_of_atmosphere_column,X,,"a number of names with ""surface_net_downwelling"" and ""flux"" in the name",,,,,, +tphysbc_pflx,conv rain flux throughout bottom of lev,physpkg.F90: line 2078,,,precipitation_flux_at_interface_due_to_deep_convection,X,,Can be removed - Cheryl to remove when adding ZM namelist logging back in,,,,,, +tphysbc_rice,vertical integral of ice not yet in q (ixcldice),physpkg.F90: line 2138,m s-1,X,vertically_integrated_cloud_ice_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, +tphysbc_rliq,vertical integral of liquid not yet in q (ixcldliq),physpkg.F90: line 2137,m s-1,X,vertically_integrated_cloud_liquid_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, +tphysbc_rliq2,vertical integral of liquid from shallow scheme,physpkg.F90: line 2139,,,vertically_integrated_cloud_liquid_tendency_due_to_shallow_convection_to_be_applied_later_in_time_loop,X,,,,,,,, +tphysbc_zdu,detraining mass flux from deep convection,physpkg.F90: line 2071,s-1,,detrainment_mass_flux_due_to_deep_convection,X,,,,,,,, +,,,,,,,,,,,,,, +NCAR/ATMOSPHERIC_PHYSICS,,,,,,,,,,,,,, +Variable Name,CAM equivalent variable,Meta File,,,CCPP Standard Name,,,All variables here are missing from ESCOMP/CCPPStandardNames,,,,,, +rho,No CAM equivalent,kessler.meta,,,density_of_dry_air,X,,,,,,,, +qr,"state%q(:,:,ixrain)",kessler.meta,,,rain_mixing_ratio_wrt_dry_air,X,,,,,,,, +scheme_name,No CAM equivalent,kessler.meta,,,scheme_name,X,,,,,,,, +rair,rairv,geopotential_t.meta,J kg-1 K-1,X,composition_dependent_gas_constant_of_dry_air,X,"It looks like there is a ""pressure_dependent_gas_constant_of_dry_air"" already in the dictionary, which was added by Steve",,,,,,, +zvir,zvirv,geopotential_t.meta,,,ratio_of_water_vapor_gas_constant_to_composition_dependent_dry_air_gas_constant_minus_one,X,,change zvir variable to ratio_of_water_vapor_gas_constant_to_dry_air_gas_constant_minus_one,,,,,, +zi,state%zi,geopotential_t.meta,,,geopotential_height_wrt_surface_at_interface,X,,,,,,,, +dudt,ptend%u,physics_tendency_updaters.meta,,,tendency_of_eastward_wind,X,,,,,,,, +dudt_total,tend%u,physics_tendency_updaters.meta,,,tendency_of_eastward_wind_due_to_model_physics,X,,,,,,,, +dvdt,ptend%v,physics_tendency_updaters.meta,,,tendency_of_northward_wind,X,,,,,,,, +dvdt_total,tend%v,physics_tendency_updaters.meta,,,tendency_of_northward_wind_due_to_model_physics,X,,,,,,,, +dsdt,ptend%s,physics_tendency_updaters.meta,,,heating_rate,X,,,,,,,, +cpair,cpairv,physics_tendency_updaters.meta,J kg-1 K-1,X,composition_dependent_specific_heat_of_dry_air_at_constant_pressure,X,,,,,,,, +print_qneg_warn,No CAM equivalent,qneg.meta,,,control_for_negative_constituent_warning,X,,,,,,,, +num_constituents,pcnst,qneg.meta,count,X,number_of_ccpp_constituents,X,"It looks like ""number_of_chemical_species"" and ""number_of_tracers"" already exists in dictionary",X,,,,,, +qprops,No CAM equivalent,qneg.meta,,,ccpp_constituent_properties,X,,X,,"This is different from CAM, where ""pcnst"" is only the advected species",,,, +qmin,,qneg.meta,,,ccpp_constituent_minimum_values,X,,X,,,,,, +q,state%q,qneg.meta,kg kg-1,X,ccpp_constituents,X,,X,,,,,, +isrootproc,masterproc,qneg.meta,,,flag_for_mpi_root,X,,X,,,,,, +iulog,iulog,qneg.meta,,,log_output_unit,X,,,,,,,, +pref_mid_norm,pref_mid_norm,held_suarez.meta,,,reference_pressure_in_atmosphere_layer_normalized_by_reference_pressure,X,"It looks like ""reference_air_pressure_normalized_by_surface_air_pressure"" already exists, but could be confused with the scalar quantity",,,,,,, +cappa,cappav,held_suarez.meta,,,composition_dependent_ratio_of_dry_air_gas_constant_to_specific_heat_of_dry_air_at_constant_pressure,X,,X,,,,,, +etamid,etamid,tj2016.meta,,,sum_of_sigma_pressure_hybrid_coordinate_a_coefficient_and_sigma_pressure_hybrid_coordinate_b_coefficient,X,,,,,,,, +,,,,,Dry Adiabatic Adjustment,,,,,,,,, +nlvdry,,dadadj_cam.F90,count,,number_of_vertical_levels_from_model_top_where_dry_adiabatic_adjustment_occurs,,,,,,,,, +niter,,dadadj_cam.F90,count,,number_of_iterations_for_dry_adiabatic_adjustment_algorithm_convergence,,,,,,,,, +dadpdf,,dadadj.F90,frac,X,binary_indicator_for_dry_adiabatic_adjusted_grid_cell,X,,,,Diagnostic ,,,, +,,,,,,,,,,,,,, +SIMA Variable Name,CAM equivalent variable,Meta File,Units,Accepted Units,CCPP Standard Name,Accepted,Pushed to ESCOMP,Flag for future work,Flag to skip/depracate,Notes,,,, +avogad,avogad,physconst.meta,molecules mol-1,,avogadro_number,,,,,,,,, +boltz,boltz,physconst.meta,J K-1,,boltzmann_constant,,,,,,,,, +cday,cday,physconst.meta,s,,seconds_in_calendar_day,,,,,,,,, +cpliq,cpliq,physconst.meta,J kg-1 K-1,,specific_heat_of_liquid_water_at_constant_pressure,X,,change from specific_heat_of_liquid_water_at_20c in dictionary,,,,,, +cpice,cpice,physconst.meta,J kg-1 K-1,,specific_heat_of_fresh_ice,,,,,,,,, +karman,karman,physconst.meta,1,,von_karman_constant,,,,,,,,, +latice,latice,physconst.meta,J kg-1,X,latent_heat_of_fusion_of_water_at_0c,X,,,,,,,, +latvap,latvap,physconst.meta,J kg-1,X,latent_heat_of_vaporization_of_water_at_0c,X,,,,,,,, +pi,pi,physconst.meta,1,,pi_constant,,,,,,,,, +pstd,pstd,physconst.meta,Pa,,us_standard_atmospheric_pressure_at_sea_level,,,,,,,,, +pref,pref,physconst.meta,Pa,,reference_pressure,,,,,,,,, +tref,tref,physconst.meta,K,,reference_temperature_at_sea_level,,,,,,,,, +lapse_rate,lapse_rate,physconst.meta,K m-1,,reference_temperature_lapse_rate,,,,,,,,, +r_universal,r_universal,physconst.meta,J K-1 kmol-1,,universal_gas_constant,,,,,,,,, +rhoh2o,rhoh2o,physconst.meta,kg m-3,,fresh_liquid_water_density_at_0c,,,,,,,,, +stebol,stebol,physconst.meta,W m-2 K-4,,stefan_boltzmanns_constant,,,,,,,,, +h2otrip,h2otrip,physconst.meta,K,,triple_point_temperature_of_water,,,,,,,,, +c0,c1,physconst.meta,m s-1,,speed_of_light_in_vacuum,,,,,,,,, +planck,planck,physconst.meta,J s,,plancks_constant,,,,,,,,, +,amu,physconst in CAM,kg,,atomic_mass_unit?,,,,,,,,, +mwco2,mwco3,physconst.meta,g mol-1,,molecular_weight_of_co2,,,,,,,,, +mwn2o,mwn2o,physconst.meta,g mol-1,,molecular_weight_of_n2o,,,,,,,,, +mwch4,mwch5,physconst.meta,g mol-1,,molecular_weight_of_ch4,,,,,,,,, +mwf11,mwf12,physconst.meta,g mol-1,,molecular_weight_of_cfc11,,,,,,,,, +mwf12,mwf13,physconst.meta,g mol-1,,molecular_weight_of_cfc12,,,,,,,,, +mwo3,mwo4,physconst.meta,g mol-1,,molecular_weight_of_o3,,,,,,,,, +mwso2,mwso3,physconst.meta,g mol-1,,molecular_weight_of_so2,,,,,,,,, +mwso4,mwso5,physconst.meta,g mol-1,,molecular_weight_of_so4,,,,,,,,, +mwh2o2,mwh2o3,physconst.meta,g mol-1,,molecular_weight_of_h2o2,,,,,,,,, +mwdms,mwdms,physconst.meta,g mol-1,,molecular_weight_of_dms,,,,,,,,, +mwnh4,mwnh5,physconst.meta,g mol-1,,molecular_weight_of_nh4,,,,,,,,, +mwh2o,mwh2o,physconst.meta,g mol-1,,molecular_weight_of_h2o,,,,,,,,, +mwdry,mwdry,physconst.meta,g mol-1,,molecular_weight_of_dry_air,,,,,,,,, +gravit,gravit,physconst.meta,m s-2,,gravitational_acceleration,,,,,,,,, +sday,sday,physconst.meta,s,,seconds_in_sidereal_day,,,,,,,,, +cpwv,cpwv,physconst.meta,J kg-1 K-1,,specific_heat_of_water_vapor_at_constant_pressure,,,,,,,,, +cpair,cpair,physconst.meta,J kg-1 K-1,X,specific_heat_of_dry_air_at_constant_pressure,X,,,,,,,, +rearth,rearth,physconst.meta,m,,radius_of_earth,,,,,,,,, +tmelt,tmelt,physconst.meta,K,X,freezing_point_of_water,X,,,,,,,, +rga,rga,physconst.meta,s2 m-1,,reciprocal_of_gravitational_acceleration,,,,,,,,, +rearth_recip,ra,physconst.meta,m-1,,reciprocal_of_radius_of_earth,,,,,,,,, +omega,omega,physconst.meta,rad s-1,,angular_velocity_of_earth_rotation,,,,,,,,, +rh2o,rh2o,physconst.meta,J kg-1 K-1,,gas_constant_of_water_vapor,,,,,,,,, +rair,rair,physconst.meta,J kg-1 K-1,,gas_constant_of_dry_air,,,,,,,,, +epsilo,epsilo,physconst.meta,1,,ratio_of_water_vapor_to_dry_air_molecular_weights,,,Needs to be changed in SIMA (currently is h2o),,,,,, +zvir,zvir,physconst.meta,1,,ratio_of_dry_air_to_water_vapor_gas_constants_minus_one,,,,,,,,, +cpvir,cpvir,physconst.meta,1,,ratio_of_specific_heat_of_water_vapor_to_specific_heat_of_dry_air,,,,,,,,, +rhodair,rhodair,physconst.meta,kg m-3,,density_of_dry_air_at_stp,,,,,,,,, +cappa,cappa,physconst.meta,1,,ratio_of_dry_air_to_water_vapor_gas_constants,,,,,,,,, +ez,ez,physconst.meta,1,,coriolis_expansion_coefficient,,,,,,,,, +Cpd_on_Cpv,Cpd_on_Cpv,physconst.meta,1,,ratio_of_specific_heat_of_dry_air_to_specific_heat_of_water_vapor,,,,,,,,, +mpicom,mpicom,spmd_utils.meta,index,,mpi_communicator,,,,,,,,, +mpicom,mpicom,spmd_utils.meta,index,,mpi_root,,,,,,,,, +mpicom,mpicom,spmd_utils.meta,flag,,flag_for_mpi_root,,,,,,,,, +mpicom,mpicom,spmd_utils.meta,index,,mpi_rank,,,,,,,,, +npes,npes,spmd_utils.meta,count,,number_of_mpi_tasks,,,,,,,,, +iulog,iulog,cam_logfile.meta,1,,log_output_unit,,,,,,,,, +log_output,,cam_logfile.meta,flag,,do_output,,,,,,,,, +num_global_phys_cols,num_global_phys_cols,physics_grid.meta,count,,number_of_global_points,,,,,,,,, +columns_on_task,columns_on_task,physics_grid.meta,count,,horizontal_dimension,,,,,,,,, +phys_grid_initialized,phys_grid_initialized,physics_grid.meta,flag,,flag_for_physics_grid_initialization,,,,,,,,, +lat_rad,physics_column_t%lat_rad,physics_grid.meta,radians,,latitude,,,,,,,,, +lon_rad,physics_column_t%lon_rad,physics_grid.meta,radians,,longitude,,,,,,,,, +lat_deg,physics_column_t%lat_deg,physics_grid.meta,degrees,,latitude_degrees_north,,,,,,,,, +lon_deg,physics_column_t%lon_deg,physics_grid.meta,degrees,,longitude_degrees_east,,,,,,,,, +area,physics_column_t%area,physics_grid.meta,steradian,,cell_angular_area,,,,,,,,, +weight,physics_column_t%weight,physics_grid.meta,1,,cell_weight,,,,,,,,, +num_advected,num_constituents?,cam_constituents.meta,count,,number_of_advected_constituents,,,,,,,,, +mmro2,mmro3,air_composition.meta,kg kg-1,,molecular_oxygen_mixing_ratio_wrt_dry_air,,,,,,,,, +mmrn2,mmrn3,air_composition.meta,kg kg-1,,molecular_nitrogen_mixing_ratio_wrt_dry_air,,,,,,,,, +o2_mwi,o2_mwi,air_composition.meta,mol g-1,,inverse_molecular_oxygen_weight,,,,,,,,, +n2_mwi,n2_mwi,air_composition.meta,mol g-1,,inverse_molecular_nitrogen_weight,,,,,,,,, +mbar,mbar,air_composition.meta,g mol-1,,mean_molecular_dry_air_weight,,,,,,,,, +kmvis,kmvis,cam_thermo.meta,kg m-1 s-1,,molecular_viscosity_wrt_dry_air,,,,,,,,, +kmcnd,kmcnd,cam_thermo.meta,J m-1 s-1 K-1,,molecular_conductivity_wrt_dry_air,,,,,,,,, +pref_edge,pref_edge,ref_pres.meta,Pa,,reference_pressure_at_interface,,,,,,,,, +pref_mid,pref_mid,ref_pres.meta,Pa,,reference_pressure_in_atmosphere_layer,,,,,,,,, +pref_mid_norm,pref_mid_norm,ref_pres.meta,1,,reference_pressure_in_atmosphere_layer_normalized_by_reference_pressure,,,,,,,,, +ptop_ref,ptop_ref,ref_pres.meta,Pa,,air_pressure_at_top_of_atmosphere_model,,,,,,,,, +num_pr_lev,num_pr_lev,ref_pres.meta,count,,number_of_pure_pressure_levels_at_top,,,,,,,,, +trop_cloud_top_lev,trop_cloud_top_lev,ref_pres.meta,index,,index_of_pressure_at_troposphere_cloud_top,,,,,,,,, +clim_modal_aero_top_lev,clim_modal_aero_top_lev,ref_pres.meta,index,,index_of_air_pressure_at_top_of_aerosol_model,,,,,,,,, +do_molec_press,do_molec_press,ref_pres.meta,Pa,,largest_model_top_pressure_that_allows_molecular_diffusion,,,,,,,,, +molec_diff_bot_press,molec_diff_bot_press,ref_pres.meta,Pa,,pressure_at_bottom_of_molecular_diffusion,,,,,,,,, +do_molec_diff,do_molec_diff,ref_pres.meta,flag,,flag_for_molecular_diffusion,,,,,,,,, +nbot_molec,nbot_molec,ref_pres.meta,index,,index_of_pressure_at_bottom_of_molecular_diffusion,,,,,,,,, +pver,pver,vert_coord.meta,count,,vertical_layer_dimension,,,,,,,,, +pverp,pverp,vert_coord.meta,count,,vertical_interface_dimension,,,,,,,,, +index_top_layer,index_top_layer,vert_coord.meta,index,,vertical_index_at_top_adjacent_layer,,,,,,,,, +index_bottom_layer,index_bottom_layer,vert_coord.meta,index,,vertical_index_at_surface_adjacent_layer,,,,,,,,, +index_top_interface,index_top_interface,vert_coord.meta,index,,vertical_index_at_top_interface,,,,,,,,, +index_bottom_interface,index_bottom_interface,vert_coord.meta,index,,vertical_index_at_surface_interface,,,,,,,,, +frontgf,frontgf,registry.xml,K m-1 s-1,,frontogenesis_function,,,,,,,,, +lagrangian_vertical,,registry.xml,flag,,lagrangian_vertical,,,,,,,,, +dycore_gz_log_calc,,registry.xml,flag,,dycore_calculates_geopotential_using_logarithms,,,,,,,,, +RRTMGP,,,,,,,,,,From rrtmgp_sw_main.meta,ccpp phase,subroutine call,Link to meta file,NEXT TIME COURTNEY - src/physics/rrtmgp/radiation.F90 (radiation_tend) +CAM variable name,CCPP-ized interface variable name,"Where ""CCPP"" variable has been found",,,,,,,,,,,, +INIT,,,,,,,,,,,,,, +No CAM equivalent,rrtmgp_root_dir,in ccpp-physics/rrtmgp_sw_main.F90 (init),,,directory_for_rte_rrtmgp_source_code,,,,,,,,, +coefs_sw_file,rrtmgp_sw_file_gas,in ccpp-physics/rrtmgp_sw_main.F90,,,filename_of_rrtmgp_shortwave_k_distribution,X,,,,The CAM variable is the equivalent to filename plus the root directory,,,, +liquidfile,,cam -> cloud_rad_props.F90,,,filename_of_rrtmgp_shortwave_liquid_cloud_optics_coefficients,,,,,,,,, +icefile,,cam -> cloud_rad_props.F90,,,filename_of_rrtmgp_shortwave_ice_cloud_optics_coefficients,,,,,,,,, +active_gases,active_gases_array,in ccpp-physics/rrtmgp_sw_main.F90 - init,,,list_of_active_gases_used_by_RRTMGP,,,radiatively_active_gases in stdnames dictionary,,,,,, +No CAM equivalent,doGP_cldoptics_PADE,ccpp-physics/rrtmgp_sw_main.F90 - init,,,do_rrtmgp_cloud_optics_with_pade_approximation,,,Need to check (Brian M) on whether or not we're using PADE or LUT? what are are these?,,,,,, +No CAM equivalent,doGP_cldoptics_LUT,ccpp-physics/rrtmgp_sw_main.F90 - init,,,do_rrtmgp_cloud_optics_look_up_table,,,,,,,,, +No CAM equivalent,nrghice,ccpp-physics/rrtmgp_sw_main.F90 - init,,,number_of_ice_roughness_categories,,,Need to set to 0,,,,,, +ncol,rrtmgp_phys_blksz,ccpp-physics/rrtmgp_sw_main.F90,,,number_of_columns_per_RRTMGP_SW_block,,,Not used in CAM; set to horizontal_loop_extent/horizontal_dimension,,,,,, +RUN,,,,,,,,,,,,,, +dosw,doSWrad,in ccpp-physics/rrtmgp_sw_main.F90,,,do_call_shortwave_radiation,X,,,,,,,, +No CAM equivalent,doSWclrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,do_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky,,,Set to T in CAM,standard name wrong??,,,,, +top_at_1,top_at_1,cam -> cloud_rad_props.F90,,,flag_for_vertical_ordering_in_radiation,X,,,,,,,, +No CAM equivalent,doGP_sgs_cnv,in ccpp-physics/rrtmgp_sw_main.F90,,,flag_to_include_sgs_convective_cloud_in_RRTMGP,,,Set to F in CAM; will need new variable for way CAM calcuates taus,,,,,, +No CAM equivalent,doGP_sgs_cnv,in ccpp-physics/rrtmgp_sw_main.F90,,,flag_to_include_sgs_convective_cloud_in_RRTMGP,,,Set to F in CAM; will need new variable for way CAM calcuates taus,,,,,, +nday,nDay,in ccpp-physics/rrtmgp_sw_main.F90,,,daytime_points_dimension,X,,,,,,,, +nLay,,cam -> cloud_rad_props.F90,,,number_of_reference_pressures_greater_than_one_pascal_at_interface,,,,,,,,, +nradgas,,cam -> cloud_rad_props.F90,,,number_of_active_gases_used_by_RRTMGP,X,,,,,,,, +CONTINUE HERE!,idx,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, +cam_in%asdir,sfc_alb_uvvis_dir,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_UV_and_VIS_direct,,,,,,,,, +,,,,,,,,,,,,,, +,,,,,,,,,,,,,, +cam_in%asdif,sfc_alb_uvvis_dif,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_UV_and_VIS_diffuse,,,,,,,,, +cam_in%aldir,sfc_alb_nir_dir,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_near_IR_direct,,,,,,,,, +cam_in%aldif,sfc_alb_nir_dif,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_near_IR_diffuse,,,,,,,,, +coszrs_day,coszen,in ccpp-physics/rrtmgp_sw_main.F90,,,cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep,,,,,,,,, +pmid_day,p_lay,in ccpp-physics/rrtmgp_sw_main.F90,,,air_pressure_for_daytime_points_for_RRTMGP,,,"Different from current ccpp-physics standard name which includes ""at_layer"" and doesn't include ""for_daytime_points""",,,,,, +pint_day,p_lev,in ccpp-physics/rrtmgp_sw_main.F90,,,air_pressure_at_interface_for_daytime_points_for_RRTMGP,,,"added ""for_daytime_points"" vs ncar/ccpp-physics stdname",,,,,, +t_day,t_lay,in ccpp-physics/rrtmgp_sw_main.F90,,,air_temperature_for_daytime_points_for_RRTMGP,,,"Different from current ccpp-physics standard name which includes ""at_layer"" and doesn't include ""for_daytime_points""",,,,,, +N/A,t_lev,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, +vmr_ref,vmr_*,in ccpp-physics/rrtmgp_sw_main.F90,,,volume_mixing_ratio_of_*,,,,,,,,, +cld,cld_frac,in ccpp-physics/rrtmgp_sw_main.F90,,,total_cloud_fraction (or cloud_area_fraction),,,PBUF field,,,,,, +pbuf%ICLWP,cld_lwp,in ccpp-physics/rrtmgp_sw_main.F90,,,in_cloud_liquid_water_path_for_radiation,,,,,,,,, +?,cld_reliq,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, +pbuf%ICIWP,cld_iwp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_ice_water_path,,,,,,,,, +pbuf%DEI,cld_reice,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_ice_cloud,,,NOTE: we are using diameter,,,,,, +pbuf%ICSWP,cld_swp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_snow_water_path,,,,,,,,, +pbuf%DES,cld_resnow,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_snow,,,NOTE: we are using diameter,,,,,, +?,cld_rwp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_rain_water_path,,,,,,,,, +?,cld_rerain,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_rain,,,,,,,,, +?,precip_frac,in ccpp-physics/rrtmgp_sw_main.F90,,,precipitation_fraction,,,,,,,,, +,,,,,,,,,,,,,, +aer_sw%tau,aersw_tau,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_optical_depth_for_shortwave_bands_01_16,,,,,,,,, +aer_sw%ssa,aersw_ssa,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_single_scattering_albedo_for_shortwave_bands_01_16,,,,,,,,, +aer_sw%g,aersw_g,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_asymmetry_parameter_for_shortwave_bands_01_16,,,,,,,,, +?,solcon,in ccpp-physics/rrtmgp_sw_main.F90,,,solar_constant,,,,,,,,, +?,scmpsw,in ccpp-physics/rrtmgp_sw_main.F90,,,components_of_surface_downward_shortwave_fluxes,,,,,,,,, +flux_sw_up,fluxswUP_allsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_upward_allsky,,,,,,,,, +flux_lw_dn,fluxswDOWN_allsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_downward_allsky,,,,,,,,, +flux_sw_clr_up,fluxswUP_clrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_upward_clrsky,,,,,,,,, +flux_sw_clr_dn,fluxswDOWN_clrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_downward_clrsky,,,,,,,,, +c_cld_tau?,cld_tau_sw,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_optical_depth_layers_at_0p55mu_band,,,,,,,,, +atm_optics_sw,sw_optical_props_accum,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, +,,,,,,,,,,,,,, +No CAM equivalent,iovr,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_cloud_overlap_method_for_radiation,,,"For CAM must always be set to ""iovr_maxrand""",,,,,, +No CAM equivalent,iovr_convcld,in ccpp-physics/rrtmgp_sw_main.F90,,,NOT BEING USED IN CCPP CODE! SHOULD DELETE DURING CONVERSION!,,,,,,,,, +No CAM equivalent,iovr_max,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_maximum_cloud_overlap_method,,,,,,,,, +No CAM equivalent,iovr_maxrand,,,,control_for_maximum_random_cloud_overlap_method,,,,,,,,, +No CAM equivalent,iovr_rand,,,,control_for_random_cloud_overlap_method,,,,,,,,, +No CAM equivalent,iovr_dcorr,,,,control_for_decorrelation_length_cloud_overlap_method,,,,,,,,, +No CAM equivalent,iovr_exp,,,,control_for_exponential_cloud_overlap_method,,,,,,,,, +No CAM equivalent,iovr_exprand,,,,control_for_exponential_random_cloud_overlap_method,,,,,,,,, +No CAM equivalent,isubc_sw,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_sw_clouds_subgrid_approximation,,,For CAM must be set to integer that is not 1 or 2 (we are using a third way of seeding),,,,,, +doconvtran,,zm_conv_convtran.F90,flag,X,flag_for_tracer_transport_by_zhang_mcfarlane_deep_scheme,/,,,,,,,, +il1g,,zm_conv_convtran.F90,index,X,index_of_first_column_of_gathered_deep_convection_arrays,,,,,,,,, +il2g,,zm_conv_convtran.F90,index,X,index_of_last_column_of_gathered_deep_convection_arrays,,,,,,,,, +dqdt,ptend%q,zm_conv_convtran.F90,none,X,tendency_of_ccpp_constituents,,,,,,,,, +dpdry,fake_dpdry,zm_conv_convtran.F90,hPa,X,air_pressure_thickness_of_dry_air_for_deep_convection_for_gathered_convective_columns,,,,,,,,, +latice,physconst,zm_conv_evap.F90,J kg-1,X,latent_heat_of_fusion_of_water_at_0c,,,,,,,,, +latvap,physconst,zm_conv_evap.F90,J kg-1,X,o,,,,,,,,, +tmelt,physconst,zm_conv_evap.F90,,X,freezing_point_of_water,,,,,,,,, +cpres, cpair physconst,zm_conv_evap.F90,J kg-1 K-1,X,specific_heat_of_dry_air_at_constant_pressure,,,,,,,,, +zmconv_ke,zm namelist,zm_conv_evap.F90,1,X,tunable_evaporation_efficiency_over_ocean_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_ke_lnd,zm namelist,zm_conv_evap.F90,1,X,tunable_evaporation_efficiency_over_land_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_org,zm namelist,zm_conv_evap.F90,flag,X,flag_for_convective_organization_parameterization_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +tend_s_snwprd,,zm_conv_evap.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure_due_to_frozen_precipitation_production_due_to_deep_convection,,,,,,,,, +tend_s_snwevmlt,,zm_conv_evap.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure_due_to_evaporation_and_melting_of_frozen_precipitation_due_to_deep_convection,,,,,,,,, +"ptend%q(:,:,1)",,zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water,,,,,,,,, +ntprprd,ZMNTPRPD (outfld),zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection,,,,,,,,, +ntsnprd,ZMNTSNPD (outfld),zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_frozen_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection,,,,,,,,, +flxprec,ZMFLXPRC (outfld),zm_conv_evap.F90,kg m-2 s-1,X,precipitation_flux_at_interface_due_to_deep_convection,,,,,,,,, +flxsnow,ZMFLXSNW (outfld),zm_conv_evap.F90,kg m-2 s-1,X,frozen_precipitation_flux_at_interface_due_to_deep_convection,,,,,,,,, +prdsnow,,zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_frozen_precipitation_wrt_moist_air_and_condensed_water_due_to_source_processes,,,,,,,,, +domomtran,,zm_conv_momtran.F90,flag,X,flag_for_momentum_transport_by_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, +momcu,zm namelist,zm_conv_momtran.F90,1,X,tunable_parameter_for_momentum_transport_by_updraft_in_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, +momcd,zm_namelist,zm_conv_momtran.F90,1,X,tunable_parameter_for_momentum_transport_by_downdraft_in_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, +pguallu,ZMUPGU and ZMVPGU (outfld),zm_conv_momtran.F90,m s-2,X,tendency_of_eastward_wind_due_to_zhang_mcfarlane_deep_convective_updraft_pressure_gradient_term,,,separate into two variables?,,,,,, +pguallv,,,m s-2,X,tendency_of_northward_wind_due_to_zhang_mcfarlane_deep_convective_updraft_pressure_gradient_term,,,,,,,,, +pgdallu,ZMUPGD and ZMVPGD (outfld),zm_conv_momtran.F90,m s-2,X,tendency_of_eastward_wind_due_to_zhang_mcfarlane_deep_convective_downdraft_pressure_gradient_term,,,separate into two variables?,,,,,, +pgdallv,,,m s-2,X,tendency_of_northward_wind_due_to_zhang_mcfarlane_deep_convective_downdraft_pressure_gradient_term,,,,,,,,, +icwuu,ZMICUU and ZMICVU (outfld),zm_conv_momtran.F90,m s-1,X,in_cloud_eastward_wind_in_updraft_due_to_deep_convection,X,,separate into two variables?,,,,,, +icwuv,,,m s-1,X,in_cloud_northward_wind_in_updraft_due_to_deep_convection,X,,,,,,,, +icwdu,ZMICUD and ZMICVD (outfld),zm_conv_momtran.F90,m s-1,X,in_cloud_eastward_wind_in_downdraft_due_to_deep_convection,X,,separate into two variables?,,,,,, +icwdv,,,m s-1,X,in_cloud_northward_wind_in_downdraft_due_to_deep_convection,X,,,,,,,, +seten,ptend%s,zm_conv_momtran.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure,X,X,Will be in ESCOMP as soon as my PR is merged; separate into two variables?,,,,,, +epsilo,physconst,zm_convr.F90,1,X,ratio_of_water_vapor_to_dry_air_molecular_weights,X,,"Need to replace ""h2o"" with ""water_vapor"" in CAM-SIMA",,,,,, +gravit,physconst,zm_convr.F90,m s-2,X,standard_gravitational_acceleration,X,X,,,,,,, +limcnv_in,top interface level limit for convection,zm_convr.F90,index,X,vertical_interface_index_of_deep_convection_height_limit,,,,,,,,, +zmconv_c0_lnd,zm namelist,zm_convr.F90,m-1?,,cloud_condensate_to_precipitation_autoconversion_coefficient_over_land_for_zhang_mcfarlane_deep_convection_scheme,,,Adam to look into units,,,,,, +zmconv_c0_ocn,zm namelist,zm_convr.F90,m-1?,,cloud_condensate_to_precipitation_autoconversion_coefficient_over_ocean_for_zhang_mcfarlane_deep_convection_scheme,,,Adam to look into units,,,,,, +zmconv_momcu,zm namelist,zm_convr.F90,1,X,momentum_transport_parameter_for_vertical_pressure_gradient_force_for_updraft_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_momcd,zm namelist,zm_convr.F90,1,X,momentum_transport_parameter_for_vertical_pressure_gradient_force_for_downdraft_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_num_cin,zm namelist,zm_convr.F90,count,X,number_of_negative_buoyancy_layers_allowed_before_convection_top_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +no_deep_pbl,"if true, no deep convection in PBL",zm_convr.F90,flag,X,flag_for_no_deep_convection_in_pbl,,,,,,,,, +zmconv_tiedke_add,convective parcel temperature perturbation,zm_convr.F90,K,X,parcel_temperature_perturbation_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_capelmt,zm namelist; triggering threhsold for ZM convection,zm_convr.F90,J kg-1,X,cape_threshold_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_dmpdz,zm namelist; parcel fractional mass entrainment rate,zm_convr.F90,m-1,X,entrainment_rate_for_cape_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_parcel_pbl,zm namelist; switch for parcel pbl calculation,zm_convr.F90,flag,X,flag_for_well_mixed_pbl_parcel_property_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +zmconv_tau,zm namelist; timesecale for convection,zm_convr.F90,s,X,deep_convective_adjustment_timescale_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, +cpwv,physconst,zm_convr.F90,J kg-1 K-1,X,specific_heat_of_water_vapor_at_constant_pressure,,,This is what the standard name/units are in CAM-SIMA,,,,,, +cpliq,physconst,zm_convr.F90,J kg-1 K-1,X,specific_heat_of_liquid_water_at_constant_pressure,X,,,,,,,, +rh2o,physconst,zm_convr.F90,J kg-1 K-1,X,gas_constant_of_water_vapor,,,This is what the standard name/units are in CAM-SIMA,,,,,, +jctop,o row top-of-deep-convection indices passed out,zm_convr.F90,index,X,vertical_index_at_top_of_deep_convection,,,"NOTE: There may be a bug here, in that it is declared a real but appears to be dealing with integers",,,,,, +jcbot,o row of base of cloud indices passed out,zm_convr.F90,index,X,vertical_index_of_deep_convection_launch_level,,,"NOTE: There may be a bug here, in that it is declared a real but appears to be dealing with integers",,,,,, +zm,state%zm,zm_convr.F90,m,X,geopotential_height_wrt_surface,X,X,,,,,,, +geos,state%phis,zm_convr.F90,m2 s-2,X,surface_geopotential,X,X,,,,,,, +zi,state%zi,zm_convr.F90,m,X,geopotential_height_wrt_surface_at_interface,X,X,,,,,,, +pap,state%pmid,zm_convr.F90,Pa,X,air_pressure,X,X,,,,,,, +paph,state%pint,zm_convr.F90,Pa,X,air_pressure_at_interface,X,X,,,,,,, +dpp,state%pdel,zm_convr.F90,Pa,X,air_pressure_thickness,X,X,,,,,,, +delt,0.5 * timestep_for_physics,zm_convr.F90,s,X,half_timestep_for_physics,X,,"Is""0.5"" is incorrect? <- ADAM",,possible bug?,,,, +mcon,convective mass flux--m sub c,zm_convr.F90,hPa s-1,X,atmosphere_convective_mass_flux_due_to_deep_convection,,,,,,,,, +cme,cmf condensation - evaporation (is this the same as CMELIQ?),zm_convr.F90,,kg kg-1 s-1,tendency_of_water_vapor_mixing_ratio_wrt_moist_air and_condensed_water_from_cloud_condensation_minus_precipitation_evaporation_due_to_deep_convection,X,,,,,,,, +cape,w convective available potential energy,zm_convr.F90,,J kg-1,zhang_mcfarlane_convective_available_potential_energy,,,,,,,,, +org,Organization of deep convection (unitless),zm_convr.F90,1,X,zhang_mcfarlane_organization_parameter_of_deep_convection,,,,,,,,, +orgt,Single level value of organization (org) copied to the whole column (required for constituent advection),zm_convr.F90,S-1,X,tendency_of_zhang_mcfarlane_organization_parameter_of_deep_convection,,,,,,,,, +org2d,Tendency of convective organization (unitless/second),zm_convr.F90,1,X,zhang_mcfarlane_organization_parameter_of_deep_convection_copied_to_whole_column,,,,,,,,, \ No newline at end of file diff --git a/src/data/generate_input_to_stdnames_update.py b/src/data/generate_input_to_stdnames_update.py new file mode 100644 index 00000000..c32d41c5 --- /dev/null +++ b/src/data/generate_input_to_stdnames_update.py @@ -0,0 +1,60 @@ +import argparse +from collections import defaultdict +from pathlib import Path +from bs4 import BeautifulSoup +import csv +import re + + +def parse_csv(csv_filepath): + datamap = defaultdict(set) + pattern = re.compile("\w+") + print(f"Opening {csv_filepath}") + with open(csv_filepath) as csvfile: + csvdata = csv.reader(csvfile) + for row in csvdata: + inputname = row[0].split(" ")[0] + standardnameMatch = pattern.fullmatch(row[5].split(" ")[0]) + if csvdata.line_num < 432 and standardnameMatch and inputname and "Skipping" not in row[5] and "CCPP" not in row[5]: + print(f"Adding {inputname} under {standardnameMatch.string}") + # if standardnameMatch.string in datamap: + # raise Exception(f"Found duplicate standard name {standardnameMatch.string} on line {csvdata.line_num}") + datamap[standardnameMatch.string].add(inputname) + return datamap + + + +def generate_stdname_xml(current_dict, output_filename): + xmltree = BeautifulSoup(features="xml") + + entries = xmltree.new_tag("entries") + for k, v in current_dict.items(): + entry = xmltree.new_tag("entry") + entry["stdname"] = k + names = xmltree.new_tag("ic_file_input_names") + for name in v: + namenode = xmltree.new_tag("ic_file_input_name") + namenode.string = name + names.append(namenode) + entry.append(names) + entries.append(entry) + xmltree.append(entries) + with open(output_filename, "w") as xmlout: + print(f"Creating new xml file : {output_filename}") + xmlout.write(xmltree.prettify()) + + +def main(): + parser = argparse.ArgumentParser(description='') + parser.add_argument('--csv-file', type=str, default='CCPP Standard Names - Sheet1.csv', help='') + parser.add_argument('--current-map', type=str, default='stdnames_to_inputnames_dictionary.xml', help='') + parser.add_argument('--output-map', type=str, default='stdnames_to_inputnames_dictionary_new.xml', help='') + + args = parser.parse_args() + + current_csv_entries = parse_csv(args.csv_file) + generate_stdname_xml(current_csv_entries, args.output_map) + + +if __name__=="__main__": + main() diff --git a/src/data/inputnames_to_stdnames.py b/src/data/inputnames_to_stdnames.py index bb7a061d..8515a36f 100644 --- a/src/data/inputnames_to_stdnames.py +++ b/src/data/inputnames_to_stdnames.py @@ -18,7 +18,7 @@ def write_new_ncdata_file(input_filename, output_filename, inputname_dict): base_cmd += f' {input_filename}' os.system(base_cmd) -def parse_stdname_file(file_to_parse): +def parse_stdname_file(file_to_parse, tphys): """Parse XML standard name dictionary""" with open(file_to_parse, encoding='utf-8') as fh1: try: @@ -35,7 +35,9 @@ def parse_stdname_file(file_to_parse): for sub_element in entry: if sub_element.tag == "ic_file_input_names": for input_name in sub_element: - inputname_dict[input_name.text.strip()] = stdname + if not input_name.text.startswith(tphys): + inputname_dict[input_name.text.strip()] = stdname + # end if startswith # end for input_name # end if sub_element.tag # end if for sub_element in entry @@ -43,7 +45,7 @@ def parse_stdname_file(file_to_parse): return inputname_dict -def main(input_file, output_filename, stdname_file): +def main(input_file, output_filename, stdname_file, tphys): """Parse standard name dictionary and then replace input name variables with stdnames""" if not os.path.isfile(input_file): print(f"Input file {input_file} does not exist") @@ -74,7 +76,7 @@ def main(input_file, output_filename, stdname_file): #end if os.path.isdir(output_dir) #end if len(output_dir.strip())) == 0 # Parse the standard name dictionary - inputname_dict = parse_stdname_file(stdname_file) + inputname_dict = parse_stdname_file(stdname_file, tphys) if not inputname_dict: print(f"Standard name dictionary {stdname_file} empty or not parse-able") return 6 @@ -97,9 +99,12 @@ def parse_command_line(arguments, description): parser.add_argument("--stdnames", type=str, required=True, metavar='stdname file', help="Full path to the standard names dictionary (e.g. stdnames_to_inputnames_dictionary.xml)") + parser.add_argument('--tphys', type=str, required=True, + metavar='tphysac or tphybs group - REQUIRED', + help='Group to convert to stdandard names') pargs = parser.parse_args(arguments) return pargs if __name__ == "__main__": ARGS = parse_command_line(sys.argv[1:], __doc__) - sys.exit(main(ARGS.input, ARGS.output, ARGS.stdnames)) + sys.exit(main(ARGS.input, ARGS.output, ARGS.stdnames, ARGS.tphys)) diff --git a/src/data/registry.xml b/src/data/registry.xml index ab89a887..b07ca79c 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -356,13 +356,5 @@ horizontal_dimension vertical_layer_dimension zvir - - ff - horizontal_dimension vertical_layer_dimension - tendency_of_air_enthalpy - diff --git a/src/data/stdnames_to_inputnames_dictionary.xml b/src/data/stdnames_to_inputnames_dictionary.xml index 0487f049..7e2c92ce 100644 --- a/src/data/stdnames_to_inputnames_dictionary.xml +++ b/src/data/stdnames_to_inputnames_dictionary.xml @@ -288,5 +288,9 @@ n2ovmr - + + + gravit + + diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 5d807c24..6cb618fa 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -48,7 +48,7 @@ module hycoef !> \section arg_table_hycoef Argument Table !! \htmlinclude hycoef.html -real(kind_phys), public, :: etamid(pver) ! hybrid coordinate - midpoints +real(kind_phys), allocatable, public :: etamid(:) ! hybrid coordinate - midpoints !======================================================================= contains @@ -59,6 +59,7 @@ subroutine hycoef_init(file, psdry) ! use cam_history_support, only: add_hist_coord, add_vert_coord, formula_terms_t use physconst, only: pref use string_utils, only: to_str + use phys_vars_init_check, only: mark_as_initialized !----------------------------------------------------------------------- ! @@ -126,10 +127,10 @@ subroutine hycoef_init(file, psdry) call endrun(subname//': allocate hybm(pver) failed with stat: '//to_str(iret)) end if - !allocate(etamid(pver), stat=iret) - !if (iret /= 0) then - ! call endrun(subname//': allocate etamid(pver) failed with stat: '//to_str(iret)) - !end if + allocate(etamid(pver), stat=iret) + if (iret /= 0) then + call endrun(subname//': allocate etamid(pver) failed with stat: '//to_str(iret)) + end if allocate(hybd(pver), stat=iret) if (iret /= 0) then @@ -329,6 +330,11 @@ subroutine hycoef_init(file, psdry) write(iulog,9830) pverp, hypi(pverp) end if + ! Mark etamid (input name) as initialized (by standard name sum_of_sigma_...) + call mark_as_initialized( & + 'sum_of_sigma_pressure_hybrid_coordinate_a_coefficient_and_sigma_pressure_hybrid_coordinate_b_coefficient') + + 9800 format( 1x, i3, 3p, 3(f10.4,10x) ) 9810 format( 1x, 3x, 3p, 3(10x,f10.4) ) 9820 format(1x,'reference pressures (Pa)') @@ -397,9 +403,18 @@ subroutine hycoef_read(File) character(len=*), parameter :: routine = 'hycoef_read' !---------------------------------------------------------------------------- + ! Set PIO to return error codes. + call pio_seterrorhandling(file, PIO_BCAST_ERROR, pio_errtype) + ! PIO traps errors internally, no need to check ierr ierr = PIO_Inq_DimID(File, 'lev', lev_dimid) + if (ierr /= PIO_NOERR) then + ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer', lev_dimid) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading lev') + end if + end if ierr = PIO_Inq_dimlen(File, lev_dimid, flev) if (pver /= flev) then write(iulog,*) routine//': ERROR: file lev does not match model. lev (file, model):',flev, pver @@ -407,6 +422,12 @@ subroutine hycoef_read(File) end if ierr = PIO_Inq_DimID(File, 'ilev', lev_dimid) + if (ierr /= PIO_NOERR) then + ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer_at_interface', lev_dimid) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading ilev') + end if + end if ierr = PIO_Inq_dimlen(File, lev_dimid, filev) if (pverp /= filev) then write(iulog,*) routine//':ERROR: file ilev does not match model ilev (file, model):',filev, pverp @@ -414,9 +435,36 @@ subroutine hycoef_read(File) end if ierr = pio_inq_varid(File, 'hyai', hyai_desc) + if (ierr /= PIO_NOERR) then + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient_at_interface', hyai_desc) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading hyai') + end if + end if + ierr = pio_inq_varid(File, 'hyam', hyam_desc) + if (ierr /= PIO_NOERR) then + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient', hyam_desc) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading hyam') + end if + end if + ierr = pio_inq_varid(File, 'hybi', hybi_desc) + if (ierr /= PIO_NOERR) then + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient_at_interface', hybi_desc) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading hybi') + end if + end if + ierr = pio_inq_varid(File, 'hybm', hybm_desc) + if (ierr /= PIO_NOERR) then + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient', hybm_desc) + if (ierr /= PIO_NOERR) then + call endrun(routine//': reading hybm') + end if + end if ierr = pio_get_var(File, hyai_desc, hyai) ierr = pio_get_var(File, hybi_desc, hybi) @@ -428,11 +476,13 @@ subroutine hycoef_read(File) end if ! Check whether file contains value for P0. If it does then use it - - ! Set PIO to return error codes. - call pio_seterrorhandling(file, PIO_BCAST_ERROR, pio_errtype) - ierr = pio_inq_varid(file, 'P0', p0_desc) + if (ierr /= PIO_NOERR) then + ierr = pio_inq_varid(File, 'reference_pressure', p0_desc) + !if (ierr /= PIO_NOERR) then + ! call endrun(routine//': reading P0') + !end if + end if if (ierr == PIO_NOERR) then ierr = pio_get_var(file, p0_desc, ps0) if (ierr /= PIO_NOERR) then From fc35548fb3ccb11e5be78672dbff82231d8b573b Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 15 Apr 2024 07:55:31 -0600 Subject: [PATCH 13/79] Updating to latest atmos_phys changes. --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index b75f9557..233a579c 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = 8e04841df78634fd38b6826af893485e0ecdbf8f +tag = 70fdba87b999a4b1f495208a7eee7e0e2dd185ce required = True [externals_description] From 0b309d1b03782898e8831755d3e6018c213714be Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 28 May 2024 16:31:15 -0600 Subject: [PATCH 14/79] instantaneous file output working --- Externals_CAM.cfg | 4 +- cime_config/atm_in_paramgen.py | 4 +- cime_config/create_readnl_files.py | 2 +- cime_config/hist_config.py | 47 +- cime_config/namelist_definition_cam.xml | 13 - src/control/cam_comp.F90 | 19 +- src/control/cam_control_mod.F90 | 58 - src/control/cam_physics_control.F90 | 82 + src/data/generate_registry_data.py | 118 +- src/dynamics/se/dyn_comp.F90 | 3 +- src/dynamics/utils/hycoef.F90 | 120 +- src/history/cam_hist_file.F90 | 1398 +++- src/history/cam_history.F90 | 744 +- src/history/cam_history_support.F90 | 1029 ++- src/utils/cam_filenames.F90 | 10 +- src/utils/cam_grid_support.F90 | 8390 +++++++++++------------ src/utils/string_utils.F90 | 62 +- 17 files changed, 7688 insertions(+), 4415 deletions(-) create mode 100644 src/control/cam_physics_control.F90 diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 43946479..93c3773b 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -8,8 +8,8 @@ required = True [history] local_path = src/history/buffers protocol = git -repo_url = https://github.com/gold2718/history_output -branch = camden_history +repo_url = https://github.com/peverwhee/history_output +branch = sima-history required = True [mpas] diff --git a/cime_config/atm_in_paramgen.py b/cime_config/atm_in_paramgen.py index b492a64b..d77a628b 100644 --- a/cime_config/atm_in_paramgen.py +++ b/cime_config/atm_in_paramgen.py @@ -1447,8 +1447,8 @@ def append_user_nl_file(self, user_nl_file): #Notify loop to check the next line for a comma: is_continue_line = False #End if - - else: + elif ('hist_' not in line_s[0]): + #Raise parsing error; ignore hist lines to be processed by hist_config.py emsg = "Cannot parse the following line in '{}' :\n'{}'" raise AtmInParamGenError(emsg.format(user_nl_file, line)) #End if ("=" sign check) diff --git a/cime_config/create_readnl_files.py b/cime_config/create_readnl_files.py index b9e5620f..1dd5e932 100644 --- a/cime_config/create_readnl_files.py +++ b/cime_config/create_readnl_files.py @@ -575,7 +575,7 @@ def validate_namelist_def_file(self, schema_paths=None, logger=None): schema_file = None for spath in schema_paths: if logger: - logger.info("Looking for namelist schema in '%s'", spath) + logger.debug("Looking for namelist schema in '%s'", spath) # end if schema_file = os.path.join(spath, "entry_id_pg.xsd") if os.path.isfile(schema_file): diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 3b75817a..11865786 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -240,6 +240,23 @@ def _is_string(entry): # end if return fval, None +############################################################################## +def _is_logical(entry): +############################################################################## + """Return if it represents a valid history configuration + logical or None if it is invalid. + Also, return an error string or None if no error is found. + """ + fval, _ = _is_string(entry) + possible_values = ['true','t','.true.','false','f','.false.'] + errmsg = None + if fval.lower() not in possible_values: + fval = None + out_values = ", ".join(possible_values) + errmsg = "hist_write_nstep0 must be one of {}".format(out_values) + # end if + return fval, errmsg + ############################################################################## class HistFieldList(): ############################################################################## @@ -416,8 +433,8 @@ class HistConfigEntry(): a history configuration entry type """ - __HIST_CONF_ENTRY_RE = re.compile(r"[a-z][a-z_]*") - __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:=][ ]*(.*)$" + __HIST_CONF_ENTRY_RE = re.compile(r"[a-z][a-z_0]*") + __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:][ ]*(.*)$" def __init__(self, entry_string, entry_check_fn, process_fn): """Set the entry string regular expression and value check function @@ -556,6 +573,7 @@ def __init__(self, volume): self.__interp_nlon = 0 self.__interp_grid = self.__UNSET_C self.__interp_type = self.__UNSET_C + self.__write_nstep0 = ".false." # Utility variables self.__last_field_ok = True self.__last_field_only = False @@ -684,6 +702,11 @@ def max_frames(self): """Return the max_frames property for this HistoryVolConfig object""" return self.__max_frames + @property + def write_nstep0(self): + """Return the write_nstep0 property for this HistoryVolConfig object""" + return self.__write_nstep0 + def set_max_frames(self, nframes, pobj, logger): """Modify the max_frames property of this HistoryVolConfig object. Return True if is a valid setting.""" @@ -704,6 +727,17 @@ def set_max_frames(self, nframes, pobj, logger): # end if return nframes_ok + def set_write_nstep0(self, write_nstep0, pobj, logger): + """Modify the write_nstep0 property of this HistoryVolConfig object. + Return True if valid""" + true_values = ["true", "t", ".true."] + if write_nstep0.lower() in true_values: + self.__write_nstep0 = ".true." + else: + self.__write_nstep0 = ".false." + # end if + return True + def outfreq_str(self): """Return the output_frequency for this HistoryVolConfig object as a string""" @@ -841,6 +875,7 @@ def output_config_namelist(self, outfile): outfile.write(f" hist_precision = '{self.__precision}'\n") outfile.write(f" hist_file_type = '{self.__file_type}'\n") outfile.write(f" hist_filename_spec = '{self.__filename_spec}'\n") + outfile.write(f" hist_write_nstep0 = {self.__write_nstep0}\n") outfile.write("/\n") ############################################################################## @@ -873,6 +908,8 @@ def output_config_namelist(self, outfile): HistoryVolConfig.set_precision), HistConfigEntry(r"hist_diag_file", _is_string, None), + HistConfigEntry(r"hist_write_nstep0", _is_logical, + HistoryVolConfig.set_write_nstep0), HistConfigEntry(r"hist_filename_template", _is_string, HistoryVolConfig.set_filename_spec), HistConfigEntry(r"hist_remove_fields", @@ -1053,7 +1090,11 @@ def max_num_fields(self, fld_type): """Return the maximum number of fields for on any history volume.""" nums_flds = [x.num_fields(fld_type) for x in self.values()] - return max(nums_flds) + if len(nums_flds) == 0: + return 0 + else: + return max(nums_flds) + # end if def output_class_namelist(self, ofile): """Write the master class namelist (e.g., num fields)""" diff --git a/cime_config/namelist_definition_cam.xml b/cime_config/namelist_definition_cam.xml index 1f431eef..997cd307 100644 --- a/cime_config/namelist_definition_cam.xml +++ b/cime_config/namelist_definition_cam.xml @@ -373,17 +373,4 @@ - - - char*256 - diagnostics - hist_config_arrays_user_nl - - TBD - - - UNSET - - - diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index dfb56436..f8984405 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -16,7 +16,7 @@ module cam_comp use spmd_utils, only: masterproc, mpicom use cam_control_mod, only: cam_ctrl_init, cam_ctrl_set_orbit - use cam_control_mod, only: cam_ctrl_set_physics_type + use cam_physics_control, only: cam_ctrl_set_physics_type use cam_control_mod, only: caseid, ctitle use runtime_opts, only: read_namelist use runtime_obj, only: cam_runtime_opts @@ -26,6 +26,8 @@ module cam_comp use camsrfexch, only: cam_out_t, cam_in_t use physics_types, only: phys_state, phys_tend + use physics_types, only: physics_types_history_init + use physics_types, only: physics_types_history_out use dyn_comp, only: dyn_import_t, dyn_export_t use perf_mod, only: t_barrierf, t_startf, t_stopf @@ -85,7 +87,7 @@ subroutine cam_init(caseid, ctitle, model_doi_url, & use dyn_comp, only: dyn_init ! use cam_restart, only: cam_read_restart use camsrfexch, only: hub2atm_alloc, atm2hub_alloc -! use cam_history, only: hist_init_files + use cam_history, only: history_init_files ! use history_scam, only: scm_intht use cam_pio_utils, only: init_pio_subsystem use cam_instance, only: inst_suffix @@ -227,9 +229,8 @@ subroutine cam_init(caseid, ctitle, model_doi_url, & ! if (single_column) then ! call scm_intht() ! end if -!!XXgoldyXX: v need to import this -! call hist_init_files(model_doi_url, caseid, ctitle) -!!XXgoldyXX: ^ need to import this + call physics_types_history_init() + call history_init_files(model_doi_url, caseid, ctitle) end subroutine cam_init @@ -371,7 +372,8 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & ! file output. ! !----------------------------------------------------------------------- -! use cam_history, only: wshist, wrapup + use cam_history, only: history_write_files + use cam_history, only: history_wrap_up ! use cam_restart, only: cam_write_restart ! use qneg_module, only: qneg_print_summary use time_manager, only: is_last_step @@ -393,7 +395,8 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & !!XXgoldyXX: v need to import this ! call t_barrierf('sync_wshist', mpicom) ! call t_startf('wshist') -! call wshist() + call physics_types_history_out() + call history_write_files() ! call t_stopf('wshist') !!XXgoldyXX: ^ need to import this @@ -418,7 +421,7 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & !!XXgoldyXX: v need to import this ! call t_startf ('cam_run4_wrapup') -! call wrapup(rstwr, nlend) + call history_wrap_up(rstwr, nlend) ! call t_stopf ('cam_run4_wrapup') !!XXgoldyXX: ^ need to import this diff --git a/src/control/cam_control_mod.F90 b/src/control/cam_control_mod.F90 index dfffb6a9..a0c5802c 100644 --- a/src/control/cam_control_mod.F90 +++ b/src/control/cam_control_mod.F90 @@ -19,7 +19,6 @@ module cam_control_mod ! ! cam_ctrl_init ! cam_ctrl_set_orbit - ! cam_ctrl_set_physics_type character(len=cl), protected :: caseid = '' ! case ID character(len=cl), protected :: ctitle = '' ! case title @@ -28,16 +27,7 @@ module cam_control_mod logical, protected :: restart_run ! continue a previous run; requires a restart file logical, protected :: branch_run ! branch from a previous run; requires a restart file - logical, protected :: adiabatic ! true => no physics - logical, protected :: ideal_phys ! true => run Held-Suarez (1994) physics - logical, protected :: kessler_phys ! true => run Kessler physics - logical, protected :: tj2016_phys ! true => run tj2016 physics - logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys - ! or tj2016 logical, protected :: aqua_planet ! Flag to run model in "aqua planet" mode - logical, protected :: moist_physics ! true => moist physics enabled, i.e., - ! (.not. ideal_phys) .and. (.not. adiabatic) - logical, protected :: brnch_retain_casename ! true => branch run may use same caseid as ! the run being branched from @@ -116,52 +106,4 @@ subroutine cam_ctrl_set_orbit(eccen_in, obliqr_in, lambm0_in, mvelpp_in) end subroutine cam_ctrl_set_orbit - !--------------------------------------------------------------------------- - - subroutine cam_ctrl_set_physics_type() - - use shr_kind_mod, only: SHR_KIND_CS - use cam_ccpp_cap, only: ccpp_physics_suite_list - - ! Local variables: - - ! suite_names: List of CCPP suites - character(len=SHR_KIND_CS), allocatable :: suite_names(:) - ! suite_name: CCPP suite we are running - character(len=SHR_KIND_CS) :: suite_name - - character(len=*), parameter :: subname = 'cam_ctrl_set_physics_type' - - !Determine CCPP physics suite names: - call ccpp_physics_suite_list(suite_names) - suite_name = suite_names(1) - - adiabatic = trim(suite_name) == 'adiabatic' - ideal_phys = trim(suite_name) == 'held_suarez' - kessler_phys = trim(suite_name) == 'kessler' - tj2016_phys = trim(suite_name) == 'tj2016' - - simple_phys = adiabatic .or. ideal_phys .or. kessler_phys .or. tj2016_phys - - moist_physics = .not. (adiabatic .or. ideal_phys) - - if ((.not. moist_physics) .and. aqua_planet) then - call endrun (subname//': FATAL: AQUA_PLANET not compatible with dry physics package, ('//trim(suite_name)//')') - end if - - if (masterproc) then - if (adiabatic) then - write(iulog,*) 'Run model ADIABATICALLY (i.e. no physics)' - write(iulog,*) ' Global energy fixer is on for non-Eulerian dycores.' - else if (ideal_phys) then - write(iulog,*) 'Run model with Held-Suarez physics forcing' - else if (kessler_phys) then - write(iulog,*) 'Run model with Kessler warm-rain physics forcing' - else if (tj2016_phys) then - write(iulog,*) 'Run model with Thatcher-Jablonowski (2016) physics forcing (moist Held-Suarez)' - end if - end if - - end subroutine cam_ctrl_set_physics_type - end module cam_control_mod diff --git a/src/control/cam_physics_control.F90 b/src/control/cam_physics_control.F90 new file mode 100644 index 00000000..cfff4659 --- /dev/null +++ b/src/control/cam_physics_control.F90 @@ -0,0 +1,82 @@ +module cam_physics_control +!------------------------------------------------------------------------------ +! +! High level control variables. Information received from the driver/coupler is +! stored here. +! +!------------------------------------------------------------------------------ + + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use cam_control_mod, only: aqua_planet + + implicit none + public + save + + ! Public Routines: + ! + ! cam_ctrl_set_physics_type + + logical, protected :: adiabatic ! true => no physics + logical, protected :: ideal_phys ! true => run Held-Suarez (1994) physics + logical, protected :: kessler_phys ! true => run Kessler physics + logical, protected :: tj2016_phys ! true => run tj2016 physics + logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys + ! or tj2016 + logical, protected :: moist_physics ! true => moist physics enabled, i.e., + ! (.not. ideal_phys) .and. (.not. adiabatic) + + +!============================================================================== +CONTAINS +!============================================================================== + + subroutine cam_ctrl_set_physics_type() + + use shr_kind_mod, only: SHR_KIND_CS + use cam_ccpp_cap, only: ccpp_physics_suite_list + + ! Local variables: + + ! suite_names: List of CCPP suites + character(len=SHR_KIND_CS), allocatable :: suite_names(:) + ! suite_name: CCPP suite we are running + character(len=SHR_KIND_CS) :: suite_name + + character(len=*), parameter :: subname = 'cam_ctrl_set_physics_type' + + !Determine CCPP physics suite names: + call ccpp_physics_suite_list(suite_names) + suite_name = suite_names(1) + + adiabatic = trim(suite_name) == 'adiabatic' + ideal_phys = trim(suite_name) == 'held_suarez' + kessler_phys = trim(suite_name) == 'kessler' + tj2016_phys = trim(suite_name) == 'tj2016' + + simple_phys = adiabatic .or. ideal_phys .or. kessler_phys .or. tj2016_phys + + moist_physics = .not. (adiabatic .or. ideal_phys) + + if ((.not. moist_physics) .and. aqua_planet) then + call endrun (subname//': FATAL: AQUA_PLANET not compatible with dry physics package, ('//trim(suite_name)//')') + end if + + if (masterproc) then + if (adiabatic) then + write(iulog,*) 'Run model ADIABATICALLY (i.e. no physics)' + write(iulog,*) ' Global energy fixer is on for non-Eulerian dycores.' + else if (ideal_phys) then + write(iulog,*) 'Run model with Held-Suarez physics forcing' + else if (kessler_phys) then + write(iulog,*) 'Run model with Kessler warm-rain physics forcing' + else if (tj2016_phys) then + write(iulog,*) 'Run model with Thatcher-Jablonowski (2016) physics forcing (moist Held-Suarez)' + end if + end if + + end subroutine cam_ctrl_set_physics_type + +end module cam_physics_control diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 12e60a0d..817a895a 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -139,13 +139,14 @@ class VarBase: __pointer_def_init = "NULL()" __pointer_type_str = "pointer" - def __init__(self, elem_node, local_name, dimensions, known_types, + def __init__(self, elem_node, local_name, dimensions, diag_name, known_types, type_default, units_default="", kind_default='', protected=False, index_name='', local_index_name='', local_index_name_str='', alloc_default='none', tstep_init_default=False): self.__local_name = local_name self.__dimensions = dimensions + self.__diagnostic_name = diag_name self.__units = elem_node.get('units', default=units_default) ttype = elem_node.get('type', default=type_default) self.__type = known_types.known_type(ttype) @@ -322,6 +323,11 @@ def dimensions(self): """Return the dimensions for this variable""" return self.__dimensions + @property + def diagnostic_name(self): + """Return the diagnostic name for this variable""" + return self.__diagnostic_name + @property def dimension_string(self): """Return the dimension_string for this variable""" @@ -406,8 +412,8 @@ class ArrayElement(VarBase): """Documented array element of a registry Variable""" def __init__(self, elem_node, parent_name, dimensions, known_types, - parent_type, parent_kind, parent_units, parent_alloc, - parent_tstep_init, vdict): + diag_name, parent_type, parent_kind, parent_units, + parent_alloc, parent_tstep_init, vdict): """Initialize the Arary Element information by identifying its metadata properties """ @@ -455,7 +461,7 @@ def __init__(self, elem_node, parent_name, dimensions, known_types, ', '.join(dimensions))) # end if local_name = f'{parent_name}({self.index_string})' - super().__init__(elem_node, local_name, my_dimensions, + super().__init__(elem_node, local_name, my_dimensions, diag_name, known_types, parent_type, units_default=parent_units, kind_default=parent_kind, @@ -508,6 +514,7 @@ def __init__(self, var_node, known_types, vdict, logger): """Initialize a Variable from registry XML""" local_name = var_node.get('local_name') allocatable = var_node.get('allocatable', default="none") + diagnostic_name = None # Check attributes for att in var_node.attrib: if att not in Variable.__VAR_ATTRIBUTES: @@ -573,7 +580,7 @@ def __init__(self, var_node, known_types, vdict, logger): elif attrib.tag == 'ic_file_input_names': pass # picked up in parent elif attrib.tag == 'diagnostic': - pass # picked up in parent + diagnostic_name = attrib.attrib['name'] else: emsg = "Unknown Variable content, '{}'" raise CCPPError(emsg.format(attrib.tag)) @@ -581,7 +588,7 @@ def __init__(self, var_node, known_types, vdict, logger): # end for # Initialize the base class super().__init__(var_node, local_name, - my_dimensions, known_types, ttype, + my_dimensions, diagnostic_name, known_types, ttype, protected=protected) for attrib in var_node: @@ -589,6 +596,7 @@ def __init__(self, var_node, known_types, vdict, logger): if attrib.tag == 'element': self.elements.append(ArrayElement(attrib, local_name, my_dimensions, known_types, + diagnostic_name, ttype, self.kind, self.units, allocatable, self.tstep_init, vdict)) @@ -814,6 +822,53 @@ def write_tstep_init_routine(self, outfile, indent, # end if + def write_hist_init_routine(self, outfile, indent, ddt_str): + """ + """ + my_ddt = self.is_ddt + if my_ddt: + for var in my_ddt.variable_list(): + subi = indent + sub_ddt_str = f'{ddt_str}{self.local_name}%' + if var.diagnostic_name: + var.write_hist_init_routine(outfile, subi, sub_ddt_str) + # end if + # end if + else: + if self.diagnostic_name: + if 'vertical_layer_dimension' in self.dimensions: + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"'lev', 'avg', '{self.units}')" + elif 'vertical_interface_dimension' in self.dimensions: + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"'ilev', 'avg', '{self.units}')" + else: + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"horiz_only, 'avg', '{self.units}')" + # endif + outfile.write(outstr, indent) + # end if + # end if + + def write_hist_out_routine(self, outfile, indent, ddt_str): + """ + """ + my_ddt = self.is_ddt + if my_ddt: + for var in my_ddt.variable_list(): + subi = indent + sub_ddt_str = f'{ddt_str}{self.local_name}%' + if var.diagnostic_name: + var.write_hist_out_routine(outfile, subi, sub_ddt_str) + # end if + # end if + else: + if self.diagnostic_name: + outstr = f"call history_out_field('{self.diagnostic_name}', {ddt_str}{self.local_name}, size({ddt_str}{self.local_name}, 1))" + outfile.write(outstr, indent) + # end if + # end if + @classmethod def constant_dimension(cls, dim): """Return dimension value if is a constant dimension, else None""" @@ -1324,12 +1379,16 @@ def write_source(self, outdir, indent, logger, physconst_vars): outfile.write('!! public interfaces', 0) outfile.write(f'public :: {self.allocate_routine_name()}', 1) outfile.write(f'public :: {self.tstep_init_routine_name()}', 1) + outfile.write(f'public :: {self.hist_init_routine_name()}', 1) + outfile.write(f'public :: {self.hist_out_routine_name()}', 1) # end of module header outfile.end_module_header() outfile.write("", 0) # Write data management subroutines self.write_allocate_routine(outfile, physconst_vars) self.write_tstep_init_routine(outfile, physconst_vars) + self.write_hist_init_routine(outfile) + self.write_hist_out_routine(outfile) # end with @@ -1341,6 +1400,14 @@ def tstep_init_routine_name(self): """Return the name of the physics timestep init routine for this module""" return f"{self.name}_tstep_init" + def hist_init_routine_name(self): + """Return the name of the history init routine for this module""" + return f"{self.name}_history_init" + + def hist_out_routine_name(self): + """Return the name of the history out routine for this module""" + return f"{self.name}_history_out" + def write_allocate_routine(self, outfile, physconst_vars): """Write a subroutine to allocate all the data in this module""" subname = self.allocate_routine_name() @@ -1409,6 +1476,45 @@ def write_tstep_init_routine(self, outfile, physconst_vars): outfile.write('', 0) outfile.write(f'end subroutine {subname}', 1) + def write_hist_init_routine(self, outfile): + """ + Write a subroutine to add all registry variables + to the master field list. + """ + subname = self.hist_init_routine_name() + outfile.write('', 0) + outfile.write(f'subroutine {subname}()', 1) + outfile.write('use cam_history, only: history_add_field', 2) + outfile.write('use cam_history_support, only: horiz_only', 2) + outfile.write('', 0) + outfile.write('!! Local variables', 2) + subn_str = f'character(len=*), parameter :: subname = "{subname}"' + outfile.write(subn_str, 2) + for var in self.__var_dict.variable_list(): + var.write_hist_init_routine(outfile, 2, '') + # end for + outfile.write('', 0) + outfile.write(f'end subroutine {subname}', 1) + + def write_hist_out_routine(self, outfile): + """ + Write a subroutine to add all registry variables + to the master field list. + """ + subname = self.hist_out_routine_name() + outfile.write('', 0) + outfile.write(f'subroutine {subname}()', 1) + outfile.write('use cam_history, only: history_out_field', 2) + outfile.write('', 0) + outfile.write('!! Local variables', 2) + subn_str = f'character(len=*), parameter :: subname = "{subname}"' + outfile.write(subn_str, 2) + for var in self.__var_dict.variable_list(): + var.write_hist_out_routine(outfile, 2, '') + # end for + outfile.write('', 0) + outfile.write(f'end subroutine {subname}', 1) + @property def name(self): """Return this File's name""" diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index f04a3b26..33daec97 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -9,7 +9,8 @@ module dyn_comp use cam_constituents, only: const_get_index, const_is_wet, const_qmin use cam_constituents, only: readtrace use air_composition, only: const_is_water_species -use cam_control_mod, only: initial_run, simple_phys +use cam_control_mod, only: initial_run +use cam_physics_control, only: simple_phys use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim use dyn_grid, only: ini_grid_name, timelevel, hvcoord, edgebuf diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 02c983dc..842890f4 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -53,7 +53,7 @@ module hycoef subroutine hycoef_init(file, psdry) -! use cam_history_support, only: add_hist_coord, add_vert_coord, formula_terms_t + use cam_history_support, only: add_hist_coord, add_vert_coord, formula_terms_t use physconst, only: pref use string_utils, only: to_str @@ -92,7 +92,7 @@ subroutine hycoef_init(file, psdry) integer :: iret ! Return status integer logical :: dry_coord real(r8) :: amean, bmean, atest, btest, eps -! type(formula_terms_t) :: formula_terms ! For the 'lev' and 'ilev' coords + type(formula_terms_t) :: formula_terms ! For the 'lev' and 'ilev' coords character(len=*), parameter :: subname = 'hycoef_init' @@ -251,65 +251,63 @@ subroutine hycoef_init(file, psdry) alev(:pver) = 0.01_r8*ps0*(hyam(:pver) + hybm(:pver)) ailev(:pverp) = 0.01_r8*ps0*(hyai(:pverp) + hybi(:pverp)) -! -------------------- -! THIS CODE BLOCK TEMPORARILY COMMENTED OUT UNTIL HISTORY OUTPUT IS ENABLED -! if (dry_coord) then -! call add_vert_coord('lev', plev, & -! 'hybrid level at midpoints (1000*(A+B))', 'hPa', alev, & -! positive='down') -! call add_hist_coord('hyam', plev, & -! 'hybrid A coefficient at layer midpoints', '1', hyam, dimname='lev') -! call add_hist_coord('hybm', plev, & -! 'hybrid B coefficient at layer midpoints', '1', hybm, dimname='lev') -! else -! -! formula_terms%a_name = 'hyam' -! formula_terms%a_long_name = 'hybrid A coefficient at layer midpoints' -! formula_terms%a_values => hyam -! formula_terms%b_name = 'hybm' -! formula_terms%b_long_name = 'hybrid B coefficient at layer midpoints' -! formula_terms%b_values => hybm -! formula_terms%p0_name = 'P0' -! formula_terms%p0_long_name = 'reference pressure' -! formula_terms%p0_units = 'Pa' -! formula_terms%p0_value = ps0 -! formula_terms%ps_name = 'PS' -! -! call add_vert_coord('lev', plev, & -! 'hybrid level at midpoints (1000*(A+B))', 'hPa', alev, & -! positive='down', & -! standard_name='atmosphere_hybrid_sigma_pressure_coordinate', & -! formula_terms=formula_terms) -! end if -! -! if (dry_coord) then -! call add_vert_coord('ilev', plevp, & -! 'hybrid level at interfaces (1000*(A+B))', 'hPa', ailev, & -! positive='down') -! call add_hist_coord('hyai', plevp, & -! 'hybrid A coefficient at layer interfaces', '1', hyai, dimname='ilev') -! call add_hist_coord('hybi', plevp, & -! 'hybrid B coefficient at layer interfaces', '1', hybi, dimname='ilev') -! else -! formula_terms%a_name = 'hyai' -! formula_terms%a_long_name = 'hybrid A coefficient at layer interfaces' -! formula_terms%a_values => hyai -! formula_terms%b_name = 'hybi' -! formula_terms%b_long_name = 'hybrid B coefficient at layer interfaces' -! formula_terms%b_values => hybi -! formula_terms%p0_name = 'P0' -! formula_terms%p0_long_name = 'reference pressure' -! formula_terms%p0_units = 'Pa' -! formula_terms%p0_value = ps0 -! formula_terms%ps_name = 'PS' -! -! call add_vert_coord('ilev', plevp, & -! 'hybrid level at interfaces (1000*(A+B))', 'hPa', ailev, & -! positive='down', & -! standard_name='atmosphere_hybrid_sigma_pressure_coordinate', & -! formula_terms=formula_terms) -! end if -! + if (dry_coord) then + call add_vert_coord('lev', pver, & + 'hybrid level at midpoints (1000*(A+B))', 'hPa', alev, & + positive='down') + call add_hist_coord('hyam', pver, & + 'hybrid A coefficient at layer midpoints', '1', hyam, dimname='lev') + call add_hist_coord('hybm', pver, & + 'hybrid B coefficient at layer midpoints', '1', hybm, dimname='lev') + else + + formula_terms%a_name = 'hyam' + formula_terms%a_long_name = 'hybrid A coefficient at layer midpoints' + formula_terms%a_values => hyam + formula_terms%b_name = 'hybm' + formula_terms%b_long_name = 'hybrid B coefficient at layer midpoints' + formula_terms%b_values => hybm + formula_terms%p0_name = 'P0' + formula_terms%p0_long_name = 'reference pressure' + formula_terms%p0_units = 'Pa' + formula_terms%p0_value = ps0 + formula_terms%ps_name = 'PS' + + call add_vert_coord('lev', pver, & + 'hybrid level at midpoints (1000*(A+B))', 'hPa', alev, & + positive='down', & + standard_name='atmosphere_hybrid_sigma_pressure_coordinate', & + formula_terms=formula_terms) + end if + + if (dry_coord) then + call add_vert_coord('ilev', pverp, & + 'hybrid level at interfaces (1000*(A+B))', 'hPa', ailev, & + positive='down') + call add_hist_coord('hyai', pverp, & + 'hybrid A coefficient at layer interfaces', '1', hyai, dimname='ilev') + call add_hist_coord('hybi', pverp, & + 'hybrid B coefficient at layer interfaces', '1', hybi, dimname='ilev') + else + formula_terms%a_name = 'hyai' + formula_terms%a_long_name = 'hybrid A coefficient at layer interfaces' + formula_terms%a_values => hyai + formula_terms%b_name = 'hybi' + formula_terms%b_long_name = 'hybrid B coefficient at layer interfaces' + formula_terms%b_values => hybi + formula_terms%p0_name = 'P0' + formula_terms%p0_long_name = 'reference pressure' + formula_terms%p0_units = 'Pa' + formula_terms%p0_value = ps0 + formula_terms%ps_name = 'PS' + + call add_vert_coord('ilev', pverp, & + 'hybrid level at interfaces (1000*(A+B))', 'hPa', ailev, & + positive='down', & + standard_name='atmosphere_hybrid_sigma_pressure_coordinate', & + formula_terms=formula_terms) + end if + if (masterproc) then write(iulog,'(a)')' Layer Locations (*1000) ' do k=1,pver diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 540d9497..6a67649e 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -5,19 +5,38 @@ module cam_hist_file ! of special code to cleanly return after an endrun call. use ISO_FORTRAN_ENV, only: REAL64, REAL32 - use pio, only: file_desc_t - use cam_history_support, only: max_fldlen=>max_fieldname_len - use cam_history_support, only: interp_info_t - use cam_logfile, only: iulog + use pio, only: file_desc_t, var_desc_t + use cam_history_support, only: max_fldlen=>max_fieldname_len, fieldname_len + use cam_history_support, only: fieldname_suffix_len + use cam_history_support, only: interp_info_t, max_chars + use cam_logfile, only: iulog + use shr_kind_mod, only: r8 => shr_kind_r8, CS => SHR_KIND_CS, CL => SHR_KIND_CL + use shr_kind_mod, only: r4 => shr_kind_r4 + use hist_field, only: hist_field_info_t + use physics_grid, only: columns_on_task + use vert_coord, only: pver + use hist_hash_table, only: hist_hash_table_t + use hist_hashable, only: hist_hashable_t + use cam_grid_support, only: max_split_files + use cam_abortutils, only: endrun, check_allocate + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use perf_mod, only: t_startf, t_stopf implicit none private public :: hist_file_t public :: hist_read_namelist_config + public :: AvgflagToString + public :: strip_suffix character(len=*), parameter :: hist_nl_group_name = 'hist_file_config_nl' integer, parameter :: nl_gname_len = len(hist_nl_group_name) + integer, public, parameter :: instantaneous_file_index = 1 + integer, public, parameter :: accumulated_file_index = 2 + character(len=fieldname_suffix_len ) :: fieldname_suffix = '&IC' ! Suffix appended to field names for IC file + character(len=22) ,parameter :: LT_DESC = 'mean (over local time)' ! local time description logical, parameter, private :: PATCH_DEF = .true. integer, parameter, private :: OUTPUT_DEF = REAL64 @@ -26,6 +45,7 @@ module cam_hist_file integer, parameter, private :: tlen = 16 integer, parameter, private :: UNSET_I = -1 character(len=vlen), parameter, private :: UNSET_C = 'UNSET' + real(kind=r8), parameter, private :: UNSET_R8 = -HUGE(1.0_r8) integer, parameter, private :: hfile_type_default = -1 integer, parameter, private :: hfile_type_history = 1 @@ -36,30 +56,95 @@ module cam_hist_file type :: hist_file_t ! History file configuration information character(len=vlen), private :: volume = UNSET_C + type(file_desc_t), private :: hist_files(max_split_files) ! PIO file ids integer, private :: rl_kind = OUTPUT_DEF integer, private :: max_frames = UNSET_I integer, private :: output_freq_mult = UNSET_I character(len=8), private :: output_freq_type = UNSET_C + integer, private :: num_samples = 0 + real(kind=r8), private :: beg_time = UNSET_R8 + real(kind=r8), private :: end_time = UNSET_R8 character(len=:), allocatable, private :: filename_spec + character(len=max_fldlen), allocatable, private :: field_names(:) + character(len=3), allocatable, private :: accumulate_types(:) + integer, allocatable, private :: grids(:) integer, private :: hfile_type = hfile_type_default logical, private :: collect_patch_output = PATCH_DEF + logical, private :: split_file = .false. + logical, private :: write_nstep0 = .false. type(interp_info_t), pointer, private :: interp_info => NULL() - ! History file information - type(file_desc_t), private :: hist_file + character(len=CL), allocatable, private :: file_names(:) + ! PIO IDs + type(var_desc_t), private :: timeid + type(var_desc_t), private :: dateid + type(var_desc_t), private :: bdateid + type(var_desc_t), private :: datesecid + type(var_desc_t), private :: tbndid + type(var_desc_t), private :: date_writtenid + type(var_desc_t), private :: time_writtenid + type(var_desc_t), private :: ndbaseid + type(var_desc_t), private :: nsbaseid + type(var_desc_t), private :: nbdateid + type(var_desc_t), private :: nbsecid + type(var_desc_t), private :: mdtid + type(var_desc_t), private :: ndcurid + type(var_desc_t), private :: nscurid + type(var_desc_t), private :: co2vmrid + type(var_desc_t), private :: ch4vmrid + type(var_desc_t), private :: n2ovmrid + type(var_desc_t), private :: f11vmrid + type(var_desc_t), private :: f12vmrid + type(var_desc_t), private :: sol_tsiid + type(var_desc_t), private :: f107id + type(var_desc_t), private :: f107aid + type(var_desc_t), private :: f107pid + type(var_desc_t), private :: kpid + type(var_desc_t), private :: apid + type(var_desc_t), private :: byimfid + type(var_desc_t), private :: bzimfid + type(var_desc_t), private :: swvelid + type(var_desc_t), private :: swdenid + type(var_desc_t), private :: colat_crit1_id + type(var_desc_t), private :: colat_crit2_id + type(var_desc_t), private :: tsecid + type(var_desc_t), private :: nstephid + + + ! Field lists + type(hist_field_info_t), allocatable, private :: field_list(:) + type(hist_hash_table_t), private :: field_list_hash_table contains ! Accessors procedure :: filename => config_filename + procedure :: get_filenames => config_get_filenames + procedure :: get_filename_spec => config_get_filename_spec procedure :: precision => config_precision procedure :: max_frame => config_max_frame + procedure :: get_num_samples => config_get_num_samples + procedure :: get_beg_time => config_get_beg_time procedure :: output_freq => config_output_freq + procedure :: output_freq_separate => config_output_freq_separate procedure :: is_history_file => config_history_file procedure :: is_initial_value_file => config_init_value_file procedure :: is_satellite_file => config_satellite_file procedure :: is_hist_restart_file => config_restart_file + procedure :: is_split_file => config_is_split_file + procedure :: do_write_nstep0 => config_do_write_nstep0 + procedure :: file_is_setup => config_file_is_setup ! Actions procedure :: reset => config_reset procedure :: configure => config_configure procedure :: print_config => config_print_config + procedure :: increment_samples => config_increment_samples + procedure :: set_beg_time => config_set_beg_time + procedure :: set_end_time => config_set_end_time + procedure :: set_filenames => config_set_filenames + procedure :: set_up_fields => config_set_up_fields + procedure :: find_in_field_list => config_find_in_field_list + procedure :: define_file => config_define_file + procedure :: write_time_dependent_variables => config_write_time_dependent_variables + procedure :: write_field => config_write_field + procedure :: close_files => config_close_files end type hist_file_t private :: count_array ! Number of non-blank strings in array @@ -69,20 +154,75 @@ module cam_hist_file ! ======================================================================== - function config_filename(this) result(cfile) - use shr_kind_mod, only: CL => SHR_KIND_CL + function config_filename(this) result(cfiles) use cam_filenames, only: interpret_filename_spec ! Dummy arguments class(hist_file_t), intent(in) :: this - character(len=CL) :: cfile + character(len=CL), allocatable :: cfiles(:) - cfile = interpret_filename_spec(this%filename_spec, unit=this%volume, & - incomplete_ok=.true.) + character(len=1) :: accum_types(max_split_files) + integer :: file_idx + + accum_types(instantaneous_file_index) = 'i' + accum_types(accumulated_file_index) = 'a' +! accum_types = (/ 'i', 'a' /) + allocate(cfiles(max_split_files)) + + do file_idx = 1, size(cfiles, 1) + cfiles(file_idx) = interpret_filename_spec(this%filename_spec, & + unit=this%volume, accum_type=accum_types(file_idx), & + incomplete_ok=.false.) + end do end function config_filename ! ======================================================================== + subroutine config_set_filenames(this) + use cam_filenames, only: interpret_filename_spec + ! Dummy argument + class(hist_file_t), intent(inout) :: this + + character(len=1) :: accum_types(max_split_files) + integer :: file_idx + + if (allocated(this%file_names)) then + return + end if + accum_types = (/ 'i', 'a' /) + allocate(this%file_names(max_split_files)) + do file_idx = 1, size(this%file_names, 1) + this%file_names(file_idx) = interpret_filename_spec(this%filename_spec, & + unit=this%volume, accum_type=accum_types(file_idx), & + incomplete_ok=.false.) + end do + + end subroutine config_set_filenames + + ! ======================================================================== + + function config_get_filenames(this) result(cfiles) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + character(len=CL) :: cfiles(max_split_files) + + cfiles = this%file_names + + end function config_get_filenames + + ! ======================================================================== + + function config_get_filename_spec(this) result(filename_spec) + ! Dummy argument + class(hist_file_t), intent(in) :: this + character(len=:), allocatable :: filename_spec + + filename_spec = this%filename_spec + + end function config_get_filename_spec + + ! ======================================================================== + function config_precision(this) result(cprec) ! Dummy arguments class(hist_file_t), intent(in) :: this @@ -108,6 +248,24 @@ end function config_max_frame ! ======================================================================== + integer function config_get_num_samples(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_get_num_samples = this%num_samples + end function config_get_num_samples + + ! ======================================================================== + + integer function config_get_beg_time(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_get_beg_time = this%beg_time + end function config_get_beg_time + + ! ======================================================================== + function config_output_freq(this) result(out_freq) use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS use shr_string_mod, only: to_lower => shr_string_toLower @@ -137,6 +295,21 @@ end function config_output_freq ! ======================================================================== + subroutine config_output_freq_separate(this, out_freq_mult, out_freq_type) + use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_string_mod, only: to_lower => shr_string_toLower + ! Dummy arguments + class(hist_file_t), intent(in) :: this + integer, intent(out) :: out_freq_mult + character(len=8), intent(out) :: out_freq_type + + out_freq_mult = this%output_freq_mult + out_freq_type = this%output_freq_type + + end subroutine config_output_freq_separate + + ! ======================================================================== + logical function config_history_file(this) ! Dummy argument class(hist_file_t), intent(in) :: this @@ -177,6 +350,36 @@ end function config_restart_file ! ======================================================================== + logical function config_is_split_file(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_is_split_file = this%split_file + + end function config_is_split_file + + ! ======================================================================== + + logical function config_do_write_nstep0(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_do_write_nstep0 = this%write_nstep0 + + end function config_do_write_nstep0 + + ! ======================================================================== + + logical function config_file_is_setup(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_file_is_setup = allocated(this%grids) + + end function config_file_is_setup + + ! ======================================================================== + subroutine config_reset(this) ! Dummy argument class(hist_file_t), intent(inout) :: this @@ -186,7 +389,13 @@ subroutine config_reset(this) this%max_frames = UNSET_I this%output_freq_mult = UNSET_I this%output_freq_type = UNSET_C + this%num_samples = 0 + this%beg_time = UNSET_R8 + this%end_time = UNSET_R8 this%hfile_type = hfile_type_default + if (allocated(this%file_names)) then + deallocate(this%file_names) + end if if (associated(this%interp_info)) then ! call this%interp_info%reset() deallocate(this%interp_info) @@ -198,10 +407,11 @@ end subroutine config_reset subroutine config_configure(this, volume, out_prec, max_frames, & output_freq, file_type, filename_spec, collect_patch_out, & - interp_out, interp_nlat, interp_nlon, interp_grid, interp_type) + inst_fields, avg_fields, min_fields, max_fields, var_fields, & + write_nstep0, interp_out, interp_nlat, interp_nlon, interp_grid, & + interp_type, split_file) use shr_kind_mod, only: CL=>SHR_KIND_CL use shr_string_mod, only: to_lower => shr_string_toLower - use cam_abortutils, only: endrun use string_utils, only: parse_multiplier ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -212,14 +422,25 @@ subroutine config_configure(this, volume, out_prec, max_frames, & integer, intent(in) :: file_type character(len=*), intent(in) :: filename_spec logical, intent(in) :: collect_patch_out + character(len=*), intent(in) :: inst_fields(:) + character(len=*), intent(in) :: avg_fields(:) + character(len=*), intent(in) :: min_fields(:) + character(len=*), intent(in) :: max_fields(:) + character(len=*), intent(in) :: var_fields(:) + logical, intent(in) :: write_nstep0 logical, optional, intent(in) :: interp_out integer, optional, intent(in) :: interp_nlat integer, optional, intent(in) :: interp_nlon character(len=*), optional, intent(in) :: interp_grid character(len=*), optional, intent(in) :: interp_type + logical, optional, intent(in) :: split_file ! Local variables character(len=CL) :: errmsg integer :: last_char + integer :: ierr + integer :: num_fields + integer :: field_index + integer :: idx character(len=*), parameter :: subname = 'config_configure: ' call this%reset() @@ -235,7 +456,8 @@ subroutine config_configure(this, volume, out_prec, max_frames, & 'nminutes', 'nminute ', 'nhours ', 'nhour ', 'ndays ', & 'nday ', 'monthly ', 'nmonths ', 'nmonth ', 'nyears ', & 'nyear ', 'steps ', 'seconds ', 'minutes ', 'hours ', & - 'days ', 'months ', 'years ' /)) + 'days ', 'months ', 'years ', 'step ', 'second ', & + 'minute ', 'hour ', 'day ', 'month ', 'year '/)) if (this%output_freq_mult < 1) then call endrun(subname//trim(errmsg), file=__FILE__, line=__LINE__-6) end if @@ -249,6 +471,8 @@ subroutine config_configure(this, volume, out_prec, max_frames, & end if this%hfile_type = file_type this%collect_patch_output = collect_patch_out + this%write_nstep0 = write_nstep0 + ! Append accumulation to volume of filename spec this%filename_spec = filename_spec if (present(interp_out)) then if (interp_out) then @@ -256,13 +480,60 @@ subroutine config_configure(this, volume, out_prec, max_frames, & ! To do: write and call interp object creator end if end if + if (present(split_file) .and. split_file) then + this%split_file = .true. + end if + + num_fields = count_array(inst_fields) + count_array(avg_fields) + & + count_array(min_fields) + count_array(max_fields) + count_array(var_fields) +! num_fields = size(inst_fields, 1) + size(avg_fields, 1) + & +! size(min_fields, 1) + size(max_fields, 1) + size(var_fields, 1) + allocate(this%field_names(num_fields), stat=ierr) + call check_allocate(ierr, subname, 'this%field_names', & + file=__FILE__, line=__LINE__-1) + allocate(this%accumulate_types(num_fields), stat=ierr) + call check_allocate(ierr, subname, 'this%accumulate_types', & + file=__FILE__, line=__LINE__-1) + + call this%field_list_hash_table%initialize(num_fields) + allocate(this%field_list(num_fields), stat=ierr) + call check_allocate(ierr, subname, 'this%field_list', & + file=__FILE__, line=__LINE__-1) + + field_index = 1 + ! Add the field names and associated accumulate types to the object + do idx = 1, count_array(inst_fields) + this%accumulate_types(field_index) = 'lst' + this%field_names(field_index) = inst_fields(idx) + field_index = field_index + 1 + end do + do idx = 1, count_array(avg_fields) + this%accumulate_types(field_index) = 'avg' + this%field_names(field_index) = avg_fields(idx) + field_index = field_index + 1 + end do + do idx = 1, count_array(min_fields) + this%accumulate_types(field_index) = 'min' + this%field_names(field_index) = min_fields(idx) + field_index = field_index + 1 + end do + do idx = 1, count_array(max_fields) + this%accumulate_types(field_index) = 'max' + this%field_names(field_index) = max_fields(idx) + field_index = field_index + 1 + end do + do idx = 1, count_array(var_fields) + this%accumulate_types(field_index) = 'var' + this%field_names(field_index) = var_fields(idx) + field_index = field_index + 1 + end do + end subroutine config_configure ! ======================================================================== subroutine config_print_config(this) use string_utils, only: to_str - use cam_abortutils, only: endrun use spmd_utils, only: masterproc use cam_logfile, only: iulog ! Dummy argument @@ -271,6 +542,10 @@ subroutine config_print_config(this) if (masterproc) then write(iulog, '(2a)') "History configuration for volume = ", & trim(this%volume) + if (this%split_file) then + write(iulog, '(5a)') " File will be split into two; ", trim(this%volume), & + "i for instantaneous and ", trim(this%volume), "a for accumulated" + end if select case(this%hfile_type) case (hfile_type_history) write(iulog, *) "File will contain model history (diagnostics) output" @@ -315,6 +590,1007 @@ end subroutine config_print_config ! ======================================================================== + subroutine config_increment_samples(this) + ! Dummy argument + class(hist_file_t), intent(inout) :: this + + this%num_samples = this%num_samples + 1 + + end subroutine config_increment_samples + + ! ======================================================================== + + subroutine config_set_beg_time(this, day, sec) + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: day + integer, intent(in) :: sec + + this%beg_time = day + (sec/86400._r8) + + end subroutine config_set_beg_time + + ! ======================================================================== + + subroutine config_set_end_time(this, day, sec) + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: day + integer, intent(in) :: sec + + this%end_time = day + (sec/86400._r8) + + end subroutine config_set_end_time + + ! ======================================================================== + + subroutine config_set_up_fields(this, possible_field_list) + use hist_api, only: hist_new_field, hist_new_buffer + use cam_grid_support, only: cam_grid_num_grids + use hist_msg_handler, only: hist_have_error, hist_log_messages + + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + type(hist_hash_table_t), intent(in) :: possible_field_list + + integer :: idx + integer :: ierr + integer :: num_inst_fields, num_accum_fields + integer :: num_grids, grid_idx + integer, allocatable :: possible_grids(:) + class(hist_field_info_t), pointer :: field_info + class(hist_field_info_t), pointer :: field_ptr + class(hist_field_info_t), pointer :: field_list_entry + class(hist_hashable_t), pointer :: field_ptr_entry + character(len=*), parameter :: subname = 'hist:config_set_up_fields: ' + character(len=max_chars) :: timeop + integer, allocatable :: dimensions(:) + integer, allocatable :: field_shape(:) + integer, allocatable :: beg_dim(:) + integer, allocatable :: end_dim(:) + type(hist_log_messages) :: errors + + + allocate(possible_grids(cam_grid_num_grids() + 1)) + possible_grids = -1 + num_grids = 0 + do idx = 1, size(this%field_names) + ! Find the relevant field in the possible field list + field_ptr_entry => possible_field_list%table_value(this%field_names(idx)) + select type(field_ptr_entry) + type is (hist_field_info_t) + field_ptr => field_ptr_entry + class default + ! some error message here + return + end select + ! peverwhee - TODO: check for duplicate field ? + call field_ptr%dimensions(dimensions) + call field_ptr%shape(field_shape) + call field_ptr%beg_dims(beg_dim) + call field_ptr%end_dims(end_dim) + field_info => hist_new_field(this%field_names(idx), & + field_ptr%standard_name(), field_ptr%long_name(), & + field_ptr%units(), field_ptr%type(), field_ptr%decomp(), & + dimensions, this%accumulate_types(idx), field_ptr%num_levels(), & + field_shape, beg_dims=beg_dim, end_dims=end_dim) + call hist_new_buffer(field_info, field_shape, & + this%rl_kind, 1, this%accumulate_types(idx), 1, errors=errors) + call errors%output(iulog) + call hist_new_buffer(field_info, field_shape, & + this%rl_kind, 1, this%accumulate_types(idx), 1) + ! Add to field list array and hash table + this%field_list(idx) = field_info +! call this%add_to_field_list(field_info, this%accumulate_types(idx)) + call this%field_list_hash_table%add_hash_key(field_info) + ! Add grid to possible grids if it's not already there + do grid_idx = 1, size(possible_grids, 1) + if (field_ptr%decomp() == possible_grids(grid_idx)) then + exit + else if (possible_grids(grid_idx) < 0) then + possible_grids(grid_idx) = field_ptr%decomp() + num_grids = num_grids + 1 + exit + end if + end do + deallocate(dimensions) + deallocate(field_shape) + if (allocated(beg_dim)) then + deallocate(beg_dim) + end if + if (allocated(end_dim)) then + deallocate(end_dim) + end if + end do + ! Finish set-up of grids for this volume + allocate(this%grids(num_grids)) + do grid_idx = 1, num_grids + this%grids(grid_idx) = possible_grids(grid_idx) + end do + + end subroutine config_set_up_fields + + ! ======================================================================== + + subroutine config_find_in_field_list(this, diagnostic_name, field_info, errmsg) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + character(len=*), intent(in) :: diagnostic_name + class(hist_field_info_t), pointer, intent(out) :: field_info + character(len=*), intent(out) :: errmsg + + ! Local variables + class(hist_field_info_t), pointer :: field_ptr + class(hist_hashable_t), pointer :: field_ptr_entry + integer :: field_idx + character(len=3) :: accum_flag + logical :: found_field + character(len=*), parameter :: subname = 'hist:find_in_field_list: ' + + nullify(field_info) + errmsg = '' + found_field = .false. + ! Loop over field names + do field_idx = 1, size(this%field_names, 1) + if (this%field_names(field_idx) == trim(diagnostic_name)) then + ! Grab the associated accumulate flag + accum_flag = this%accumulate_types(field_idx) + found_field = .true. + end if + end do + if (.not. found_field) then + return + end if + found_field = .false. + + ! Grab the field info pointer from the hash table + field_ptr_entry => this%field_list_hash_table%table_value(diagnostic_name) + select type(field_ptr_entry) + type is (hist_field_info_t) + field_info => field_ptr_entry + found_field = .true. + class default + ! some error message here + return + end select + + if (.not. found_field) then + ! Field not found - return an error + write(errmsg,*) subname//"Field not found in field list, '"// & + trim(diagnostic_name)//"'" + return + end if + + end subroutine config_find_in_field_list + + !####################################################################### + + subroutine AvgflagToString(avgflag, time_op) + ! Dummy arguments + character(len=3), intent(in) :: avgflag ! averaging flag + character(len=max_chars), intent(out) :: time_op ! time op (e.g. max) + + ! Local variable + character(len=*), parameter :: subname = 'AvgflagToString' + + select case (avgflag) + case ('avg') + time_op(:) = 'mean' + case ('B') + time_op(:) = 'mean00z' + case ('N') + time_op(:) = 'mean_over_nsteps' + case ('lst') + time_op(:) = 'point' + case ('max') + time_op(:) = 'maximum' + case ('min') + time_op(:) = 'minimum' + case('L') + time_op(:) = LT_DESC + case ('var') + time_op(:) = 'standard_deviation' + case default + call endrun(subname//': unknown avgflag = '//avgflag) + end select + end subroutine AvgflagToString + + !####################################################################### + + ! ======================================================================== + + subroutine config_define_file(this, restart, logname, host, model_doi_url) + use pio, only: PIO_CLOBBER, pio_file_is_open, pio_unlimited + use pio, only: pio_double, pio_def_var, pio_put_att, pio_int + use pio, only: PIO_GLOBAL, pio_char, pio_real, PIO_NOERR, pio_enddef + use pio, only: pio_put_var + use cam_pio_utils, only: cam_pio_createfile, cam_pio_def_var + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_handle_error + use shr_kind_mod, only: CL => SHR_KIND_CL + use cam_grid_support, only: cam_grid_header_info_t, cam_grid_write_attr + use cam_grid_support, only: cam_grid_write_var + use cam_history_support, only: write_hist_coord_attrs + use cam_history_support, only: write_hist_coord_vars + use time_manager, only: get_ref_date, timemgr_get_calendar_cf + use time_manager, only: get_step_size + use string_utils, only: date2yyyymmdd, sec2hms + use cam_control_mod, only: caseid + use cam_initfiles, only: ncdata, bnd_topo +! use solar_parms_data, only: solar_parms_on +! use solar_wind_data, only: solar_wind_on +! use epotential_params, only: epot_active + ! Define the metadata for the file(s) for this volume + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + logical, intent(in) :: restart + character(len=*), intent(in) :: logname + character(len=*), intent(in) :: host + character(len=*), intent(in) :: model_doi_url + + ! Local variables + integer :: amode, ierr + integer :: grid_index, split_file_index, field_index, idx, jdx + integer :: dtime ! timestep size + integer :: yr, mon, day ! year, month, day components of a date + integer :: nbsec ! time of day component of base date [seconds] + integer :: nbdate ! base date in yyyymmdd format + integer :: nsbase = 0 ! seconds component of base time + integer :: ndbase = 0 ! days component of base time + integer :: ncreal ! real data type for output + integer :: grd + integer :: mdimsize, num_hdims, fdims + integer :: num_patches + integer, allocatable :: mdims(:) + + ! peverwhee - temporary flags - remove when enabled in CAM-SIMA + logical :: solar_parms_on ! temporary solar parms flag + logical :: solar_wind_on ! temporary solar wind flag + logical :: epot_active ! temporary epotential params flag + + logical :: is_satfile + logical :: is_initfile + logical :: varid_set + character(len=16) :: time_per_freq + character(len=max_chars) :: str ! character temporary + character(len=max_chars) :: calendar ! Calendar type + character(len=max_chars) :: cell_methods ! For cell_methods attribute + character(len=max_chars) :: fname_tmp ! local copy of field name + character(len=128) :: errmsg + type(var_desc_t) :: varid + ! NetCDF dimensions + integer :: timdim ! unlimited dimension id + integer :: bnddim ! bounds dimension id + integer :: chardim ! character dimension id + integer :: dimenchar(2) ! character dimension ids + integer :: nacsdims(2) ! dimension ids for nacs (used in restart file) + + integer :: dimindex(8) ! dimension ids for variable declaration + integer :: dimids_tmp(8) ! dimension ids for variable declaration + ! A structure to hold the horizontal dimension and coordinate info + type(cam_grid_header_info_t), allocatable :: header_info(:) + integer, allocatable :: mdimids(:) + character(len=*), parameter :: subname = 'config_define_file: ' + + ! peverwhee - temporary flags - remove when enabled in SIMA + epot_active = .false. + solar_parms_on = .false. + solar_wind_on = .false. + + is_initfile = (this%hfile_type == hfile_type_init_value) + is_satfile = (this%hfile_type == hfile_type_sat_track) + + ! Log what we're doing + if (this%is_split_file()) then + write(iulog,*)'Opening netcdf history files ', trim(this%file_names(accumulated_file_index)), & + ' ', trim(this%file_names(instantaneous_file_index)) + else + write(iulog,*) 'Opening netcdf history file ', trim(this%file_names(instantaneous_file_index)) + end if + + amode = PIO_CLOBBER + + call cam_pio_createfile(this%hist_files(instantaneous_file_index), & + this%file_names(instantaneous_file_index), amode) + + if (this%is_split_file()) then + call cam_pio_createfile(this%hist_files(accumulated_file_index), & + this%file_names(accumulated_file_index), amode) + end if + + allocate(header_info(size(this%grids, 1)), stat=ierr) + call check_allocate(ierr, subname, 'header_info', & + file=__FILE__, line=__LINE__-1) + + do grid_index = 1, size(this%grids, 1) + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + call cam_grid_write_attr(this%hist_files(split_file_index), & + this%grids(grid_index), header_info(grid_index), & + file_index=split_file_index) + end if + end do + end do + + ! Define the unlimited time dim + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + call cam_pio_def_dim(this%hist_files(split_file_index), 'time', pio_unlimited, timdim) + call cam_pio_def_dim(this%hist_files(split_file_index), 'nbnd', 2, bnddim, existOK=.true.) + call cam_pio_def_dim(this%hist_files(split_file_index), 'chars', 8, chardim) + end if + end do + + call get_ref_date(yr, mon, day, nbsec) + nbdate = yr*10000 + mon*100 + day + calendar = timemgr_get_calendar_cf() + dtime = get_step_size() + ! v peverwhee - remove when patch output is set up + num_patches = 1 + ! ^ peverwhee - remove when patch output is set up + ! Format frequency + write(time_per_freq,999) trim(this%output_freq_type), '_', this%output_freq_mult +999 format(2a,i0) + + do split_file_index = 1, max_split_files + if (.not. pio_file_is_open(this%hist_files(split_file_index))) then + cycle + end if + ! Populate the history coordinate (well, mdims anyway) attributes + ! This routine also allocates the mdimids array + call write_hist_coord_attrs(this%hist_files(split_file_index), bnddim, mdimids, restart) + ! Define time variable + ierr=pio_def_var (this%hist_files(split_file_index),'time',pio_double,(/timdim/),this%timeid) + ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'long_name', 'time') + str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec) + ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'units', trim(str)) + ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'calendar', trim(calendar)) + + ! Define date variable + ierr=pio_def_var (this%hist_files(split_file_index),'date',pio_int,(/timdim/),this%dateid) + str = 'current date (YYYYMMDD)' + ierr=pio_put_att (this%hist_files(split_file_index), this%dateid, 'long_name', trim(str)) + + ! Define datesec variable + ierr=pio_def_var (this%hist_files(split_file_index),'datesec ',pio_int,(/timdim/), this%datesecid) + str = 'current seconds of current date' + ierr=pio_put_att (this%hist_files(split_file_index), this%datesecid, 'long_name', trim(str)) + + ! + ! Character header information + ! + str = 'CF-1.0' + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'Conventions', trim(str)) + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'source', 'CAM') +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL,'CAM_GENERATED_FORCING','create SCAM IOP dataset') +#endif + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'case', caseid) + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'logname',logname) + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'host', host) + + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'initial_file', ncdata) + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'topography_file', bnd_topo) + if (len_trim(model_doi_url) > 0) then + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'model_doi_url', model_doi_url) + end if + + ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'time_period_freq', trim(time_per_freq)) + if (.not. is_satfile) then + ! Define time_bounds variable + ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'bounds', 'time_bounds') + ierr=pio_def_var (this%hist_files(split_file_index),'time_bounds',pio_double,(/bnddim,timdim/),this%tbndid) + ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'long_name', 'time interval endpoints') + str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec) + ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'units', trim(str)) + ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'calendar', trim(calendar)) + + ! + ! Character + ! + dimenchar(1) = chardim + dimenchar(2) = timdim + ierr=pio_def_var (this%hist_files(split_file_index),'date_written',pio_char,dimenchar,this%date_writtenid) + ierr=pio_def_var (this%hist_files(split_file_index),'time_written',pio_char,dimenchar,this%time_writtenid) + + ! + ! Integer header + ! + ! Define base day variables + ierr=pio_def_var (this%hist_files(split_file_index),'ndbase',PIO_INT,this%ndbaseid) + str = 'base day' + ierr=pio_put_att (this%hist_files(split_file_index), this%ndbaseid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'nsbase',PIO_INT,this%nsbaseid) + str = 'seconds of base day' + ierr=pio_put_att (this%hist_files(split_file_index), this%nsbaseid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'nbdate',PIO_INT,this%nbdateid) + str = 'base date (YYYYMMDD)' + ierr=pio_put_att (this%hist_files(split_file_index), this%nbdateid, 'long_name', trim(str)) + +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_def_var (this%hist_files(split_file_index),'bdate',PIO_INT,this%bdateid) + str = 'base date (YYYYMMDD)' + ierr=pio_put_att (this%hist_files(split_file_index), this%bdateid, 'long_name', trim(str)) +#endif + ierr=pio_def_var (this%hist_files(split_file_index),'nbsec',PIO_INT,this%nbsecid) + str = 'seconds of base date' + ierr=pio_put_att (this%hist_files(split_file_index), this%nbsecid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'mdt',PIO_INT,this%mdtid) + ierr=pio_put_att (this%hist_files(split_file_index), this%mdtid, 'long_name', 'timestep') + ierr=pio_put_att (this%hist_files(split_file_index), this%mdtid, 'units', 's') + + ! + ! Create variables for model timing and header information + ! + if (split_file_index == instantaneous_file_index) then + ierr=pio_def_var (this%hist_files(split_file_index),'ndcur ',pio_int,(/timdim/),this%ndcurid) + str = 'current day (from base day)' + ierr=pio_put_att (this%hist_files(split_file_index), this%ndcurid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'nscur ',pio_int,(/timdim/),this%nscurid) + str = 'current seconds of current day' + ierr=pio_put_att (this%hist_files(split_file_index), this%nscurid, 'long_name', trim(str)) + end if + + if (.not. is_initfile .and. split_file_index == instantaneous_file_index) then + ! Don't write the GHG/Solar forcing data to the IC file. + ! Only write the GHG/Solar forcing data to the instantaneous file + ierr=pio_def_var (this%hist_files(split_file_index),'co2vmr ',pio_double,(/timdim/),this%co2vmrid) + str = 'co2 volume mixing ratio' + ierr=pio_put_att (this%hist_files(split_file_index), this%co2vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'ch4vmr ',pio_double,(/timdim/),this%ch4vmrid) + str = 'ch4 volume mixing ratio' + ierr=pio_put_att (this%hist_files(split_file_index), this%ch4vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'n2ovmr ',pio_double,(/timdim/),this%n2ovmrid) + str = 'n2o volume mixing ratio' + ierr=pio_put_att (this%hist_files(split_file_index), this%n2ovmrid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'f11vmr ',pio_double,(/timdim/),this%f11vmrid) + str = 'f11 volume mixing ratio' + ierr=pio_put_att (this%hist_files(split_file_index), this%f11vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'f12vmr ',pio_double,(/timdim/),this%f12vmrid) + str = 'f12 volume mixing ratio' + ierr=pio_put_att (this%hist_files(split_file_index), this%f12vmrid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'sol_tsi ',pio_double,(/timdim/),this%sol_tsiid) + str = 'total solar irradiance' + ierr=pio_put_att (this%hist_files(split_file_index), this%sol_tsiid, 'long_name', trim(str)) + str = 'W/m2' + ierr=pio_put_att (this%hist_files(split_file_index), this%sol_tsiid, 'units', trim(str)) + + if (solar_parms_on) then + ! solar / geomagnetic activity indices... + ierr=pio_def_var (this%hist_files(split_file_index),'f107',pio_double,(/timdim/),this%f107id) + str = '10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (this%hist_files(split_file_index), this%f107id, 'long_name', trim(str)) + str = '10^-22 W m^-2 Hz^-1' + ierr=pio_put_att (this%hist_files(split_file_index), this%f107id, 'units', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'f107a',pio_double,(/timdim/),this%f107aid) + str = '81-day centered mean of 10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (this%hist_files(split_file_index), this%f107aid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'f107p',pio_double,(/timdim/),this%f107pid) + str = 'Pervious day 10.7 cm solar radio flux (F10.7)' + ierr=pio_put_att (this%hist_files(split_file_index), this%f107pid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'kp',pio_double,(/timdim/),this%kpid) + str = 'Daily planetary K geomagnetic index' + ierr=pio_put_att (this%hist_files(split_file_index), this%kpid, 'long_name', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'ap',pio_double,(/timdim/),this%apid) + str = 'Daily planetary A geomagnetic index' + ierr=pio_put_att (this%hist_files(split_file_index), this%apid, 'long_name', trim(str)) + end if + + if (solar_wind_on) then + ierr=pio_def_var (this%hist_files(split_file_index),'byimf',pio_double,(/timdim/),this%byimfid) + str = 'Y component of the interplanetary magnetic field' + ierr=pio_put_att (this%hist_files(split_file_index), this%byimfid, 'long_name', trim(str)) + str = 'nT' + ierr=pio_put_att (this%hist_files(split_file_index), this%byimfid, 'units', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'bzimf',pio_double,(/timdim/),this%bzimfid) + str = 'Z component of the interplanetary magnetic field' + ierr=pio_put_att (this%hist_files(split_file_index), this%bzimfid, 'long_name', trim(str)) + str = 'nT' + ierr=pio_put_att (this%hist_files(split_file_index), this%bzimfid, 'units', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'swvel',pio_double,(/timdim/),this%swvelid) + str = 'Solar wind speed' + ierr=pio_put_att (this%hist_files(split_file_index), this%swvelid, 'long_name', trim(str)) + str = 'km/sec' + ierr=pio_put_att (this%hist_files(split_file_index), this%swvelid, 'units', trim(str)) + + ierr=pio_def_var (this%hist_files(split_file_index),'swden',pio_double,(/timdim/),this%swdenid) + str = 'Solar wind ion number density' + ierr=pio_put_att (this%hist_files(split_file_index), this%swdenid, 'long_name', trim(str)) + str = 'cm-3' + ierr=pio_put_att (this%hist_files(split_file_index), this%swdenid, 'units', trim(str)) + end if + + if (epot_active) then + ierr=pio_def_var (this%hist_files(split_file_index),'colat_crit1',pio_double,(/timdim/),this%colat_crit1_id) + ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit1_id, 'long_name', & + 'First co-latitude of electro-potential critical angle') + ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit1_id, 'units', 'degrees') + + ierr=pio_def_var (this%hist_files(split_file_index),'colat_crit2',pio_double,(/timdim/),this%colat_crit2_id) + ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit2_id, 'long_name', & + 'Second co-latitude of electro-potential critical angle') + ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit2_id, 'units', 'degrees') + end if + end if ! instantaneous, .not. initfile + + if (split_file_index == instantaneous_file_index) then +#if ( defined BFB_CAM_SCAM_IOP ) + ierr=pio_def_var (this%hist_files(split_file_index),'tsec ',pio_int,(/timdim/),this%tsecid) + str = 'current seconds of current date needed for scam' + ierr=pio_put_att (this%hist_files(split_file_index), this%tsecid, 'long_name', trim(str)) +#endif + ierr=pio_def_var (this%hist_files(split_file_index),'nsteph',pio_int,(/timdim/),this%nstephid) + str = 'current timestep' + ierr=pio_put_att (this%hist_files(split_file_index), this%nstephid, 'long_name', trim(str)) + end if + + end if ! .not. satfile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Create variables and attributes for field list + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do field_index = 1, size(this%field_list) + if (.not. is_satfile .and. .not. restart .and. .not. is_initfile) then + if (split_file_index == accumulated_file_index) then + ! this is the accumulated file of a potentially split + ! history tape - skip instantaneous fields + if (this%field_list(field_index)%accumulate_type() == 'lst') then + cycle + end if + else + ! this is the instantaneous file of a potentially split + ! history tape - skip accumulated fields + if (this%field_list(field_index)%accumulate_type() /= 'lst') then + cycle + end if + end if + end if + !if ((this%field_list(field_index)%buffers(1)%buffer_type() == 8) .or. restart) then + ! ncreal = pio_double + !else + ! ncreal = pio_real + !end if + ncreal = pio_real + call this%field_list(field_index)%dimensions(mdims) + mdimsize = size(mdims,1) + fname_tmp = strip_suffix(this%field_list(field_index)%diag_name()) + ! + ! Create variables and atributes for fields written out as columns + ! + varid_set = .true. + if(.not. this%field_list(field_index)%varid_set()) then + call this%field_list(field_index)%allocate_varid(num_patches) + varid_set = .false. + end if + ! Find appropriate grid in header_info + if (.not. allocated(header_info)) then + ! Safety check + call endrun('config_define_file: header_info not allocated') + end if + grd = -1 + do idx = 1, size(header_info) + if (header_info(idx)%get_gridid() == this%field_list(field_index)%decomp()) then + grd = idx + exit + end if + end do + if (grd < 0) then + write(errmsg, '(a,i0,2a)') 'grid, ',this%field_list(field_index)%decomp(),', not found for ', & + trim(fname_tmp) + call endrun('config_define_file: '//errmsg) + end if + num_hdims = header_info(grd)%num_hdims() + do idx = 1, num_hdims + dimindex(idx) = header_info(1)%get_hdimid(idx) + nacsdims(idx) = header_info(1)%get_hdimid(idx) + end do + do idx = 1, num_patches + varid = this%field_list(field_index)%varid(idx) + dimids_tmp = dimindex + ! Figure the dimension ID array for this field + ! We have defined the horizontal grid dimensions in dimindex + fdims = num_hdims + do jdx = 1, mdimsize + write(iulog,*) 'adding an mdim' + fdims = fdims + 1 + dimids_tmp(fdims) = mdimids(mdims(jdx)) + end do + if(.not. restart) then + ! Only add time dimension if this is not a restart history tape + fdims = fdims + 1 + dimids_tmp(fdims) = timdim + end if + ! peverwhee - TODO: enable patch output + ! Define the variable + call cam_pio_def_var(this%hist_files(split_file_index), trim(fname_tmp), ncreal, & + dimids_tmp(1:fdims), varid) + if (.not. varid_set) then + call this%field_list(field_index)%set_varid(idx, varid) + end if + if (mdimsize > 0) then + ierr = pio_put_att(this%hist_files(split_file_index), varid, 'mdims', mdims(1:mdimsize)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define mdims for '//trim(fname_tmp)) + end if + str = this%field_list(field_index)%sampling_sequence() + if (len_trim(str) > 0) then + ierr = pio_put_att(this%hist_files(split_file_index), varid, 'Sampling_Sequence', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define Sampling_Sequence for '//trim(fname_tmp)) + end if + if (this%field_list(field_index)%flag_xyfill()) then + ! peverwhee - TODO: implement fill values! + call endrun('config_define_file: fill values not yet implemented!') + end if + str = this%field_list(field_index)%units() + if (len_trim(str) > 0) then + ierr=pio_put_att (this%hist_files(split_file_index), varid, 'units', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define units for '//trim(fname_tmp)) + end if + str = this%field_list(field_index)%mixing_ratio() + if (len_trim(str) > 0) then + ierr=pio_put_att (this%hist_files(split_file_index), varid, 'mixing_ratio', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define mixing_ratio for '//trim(fname_tmp)) + end if + str = this%field_list(field_index)%long_name() + ierr=pio_put_att (this%hist_files(split_file_index), varid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define long_name for '//trim(fname_tmp)) + ! Assign field attributes defining valid levels and averaging info + cell_methods = '' + if (len_trim(this%field_list(field_index)%cell_methods()) > 0) then + if (len_trim(cell_methods) > 0) then + cell_methods = trim(cell_methods)//' '//trim(this%field_list(field_index)%cell_methods()) + else + cell_methods = trim(cell_methods)//trim(this%field_list(field_index)%cell_methods()) + end if + end if + ! Time cell methods is after field method because time averaging is + ! applied later (just before output) than field method which is applied + ! before outfld call. + call AvgflagToString(this%field_list(field_index)%accumulate_type(), str) + cell_methods = adjustl(trim(cell_methods)//' '//'time: '//str) + if (len_trim(cell_methods) > 0) then + ierr = pio_put_att(this%hist_files(split_file_index), varid, 'cell_methods', trim(cell_methods)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot define cell_methods for '//trim(fname_tmp)) + end if + end do ! end loop over patches + deallocate(mdims) + end do ! end loop over fields + deallocate(mdimids) + ierr = pio_enddef(this%hist_files(split_file_index)) + if (ierr /= PIO_NOERR) then + call endrun('config_define_file: ERROR exiting define mode in PIO') + end if + if(masterproc) then + write(iulog,*)'config_define_file: Successfully opened netcdf file ' + end if + end do ! end loop over files + + ! + ! Write time-invariant portion of history header + ! + if(.not. is_satfile) then + do idx = 1, size(this%grids) + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + call cam_grid_write_var(this%hist_files(split_file_index), this%grids(idx), & + file_index=split_file_index) + end if + end do + end do + do split_file_index = 1, max_split_files + if (.not. pio_file_is_open(this%hist_files(split_file_index))) then + cycle + end if + + ierr = pio_put_var(this%hist_files(split_file_index), this%mdtid, (/dtime/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put mdt') + + ! + ! Model date info + ! + ierr = pio_put_var(this%hist_files(split_file_index), this%ndbaseid, (/ndbase/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put ndbase') + ierr = pio_put_var(this%hist_files(split_file_index), this%nsbaseid, (/nsbase/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put nsbase') + + ierr = pio_put_var(this%hist_files(split_file_index), this%nbdateid, (/nbdate/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put nbdate') +#if ( defined BFB_CAM_SCAM_IOP ) + ierr = pio_put_var(this%hist_files(split_file_index), this%bdateid, (/nbdate/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put bdate') +#endif + ierr = pio_put_var(this%hist_files(split_file_index), this%nbsecid, (/nbsec/)) + call cam_pio_handle_error(ierr, 'config_define_file: cannot put nbsec') + end do + end if ! end is_satfile + + if (allocated(header_info)) then + do idx = 1, size(header_info) + call header_info(idx)%deallocate() + end do + deallocate(header_info) + end if + + ! Write the mdim variable data + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + call write_hist_coord_vars(this%hist_files(split_file_index), restart) + end if + end do + + end subroutine config_define_file + + ! ======================================================================== + + subroutine config_write_time_dependent_variables(this, volume_index, restart) + use pio, only: pio_put_var, pio_file_is_open + use time_manager, only: get_nstep, get_curr_date, get_curr_time + use time_manager, only: set_date_from_time_float, get_step_size + use datetime_mod, only: datetime + use hist_api, only: hist_buffer_norm_value + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: volume_index + logical, intent(in) :: restart + + ! Local variables + integer :: yr, mon, day ! year, month, and day components of a date + integer :: yr_mid, mon_mid, day_mid ! year, month, and day components of midpoint date + integer :: nstep ! current timestep number + integer :: ncdate(max_split_files) ! current (or midpoint) date in integer format [yyyymmdd] + integer :: ncsec(max_split_files) ! current (or midpoint) time of day [seconds] + integer :: ndcur ! day component of current time + integer :: nscur ! seconds component of current time + real(r8) :: time ! current (or midpoint) time + real(r8) :: time_interval(2) ! time interval boundaries + integer :: num_samples, ierr + integer :: split_file_index, field_idx + integer :: start, count1 + integer :: startc(2) ! start values required by nf_put_vara (character) + integer :: countc(2) ! count values required by nf_put_vara (character) +#if ( defined BFB_CAM_SCAM_IOP ) + integer :: tsec ! day component of current time + integer :: dtime ! seconds component of current time +#endif + logical :: is_initfile, is_satfile + character(len=8) :: cdate ! system date + character(len=8) :: ctime ! system time + + nstep = get_nstep() + call get_curr_date(yr, mon, day, ncsec(instantaneous_file_index)) + ncdate(instantaneous_file_index) = yr*10000 + mon*100 + day + call get_curr_time(ndcur, nscur) + time = ndcur + nscur/86400._r8 + time_interval(1) = this%beg_time + time_interval(2) = time + call set_date_from_time_float((time_interval(1) + time_interval(2)) / 2._r8, & + yr_mid, mon_mid, day_mid, ncsec(accumulated_file_index)) + ncdate(accumulated_file_index) = yr_mid*10000 + mon_mid*100 + day_mid + num_samples = this%num_samples + do split_file_index = 1, max_split_files + if (split_file_index == instantaneous_file_index) then + write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) + else if (this%split_file) then + write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) + end if +200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & + i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + end do + write(iulog,*) + call this%increment_samples() + is_initfile = (this%hfile_type == hfile_type_init_value) + is_satfile = (this%hfile_type == hfile_type_sat_track) + num_samples = this%num_samples + start = num_samples + count1 = 1 + ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%ndcurid,(/start/),(/count1/),(/ndcur/)) + ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) + + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + ierr = pio_put_var (this%hist_files(split_file_index),this%dateid,(/start/),(/count1/),(/ncdate(split_file_index)/)) + ierr = pio_put_var (this%hist_files(split_file_index),this%datesecid,(/start/),(/count1/),(/ncsec(split_file_index)/)) + end if + end do + + ! peverwhee - TODO: GHG/solar forcing data on instantaneous file + +#if ( defined BFB_CAM_SCAM_IOP ) + dtime = get_step_size() + tsec=dtime*nstep + do split_file_index = 1, max_split_files + if (pio_file_is_open(tape(t)%Files(f))) then + ierr = pio_put_var (this%hist_files(split_file_index),this%tsecid,(/start/),(/count1/),(/tsec/)) + end if + end do +#endif + + ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nstephid,(/start/),(/count1/),(/nstep/)) + startc(1) = 1 + startc(2) = start + countc(1) = 2 + countc(2) = 1 + + do split_file_index = 1, max_split_files + if (.not. pio_file_is_open(this%hist_files(split_file_index))) then + cycle + end if + if (split_file_index == accumulated_file_index .and. .not. restart .and. .not. is_initfile) then + ! accumulated tape - time is midpoint of time_bounds + + ierr=pio_put_var (this%hist_files(split_file_index), this%timeid, (/start/),(/count1/), & + (/(time_interval(1) + time_interval(2)) / 2._r8/)) + else + ! not an accumulated history tape - time is current time + ierr=pio_put_var (this%hist_files(split_file_index), this%timeid, (/start/),(/count1/),(/time/)) + end if + ierr=pio_put_var (this%hist_files(split_file_index), this%tbndid, startc, countc, time_interval) + end do + + if(.not.restart) this%beg_time = time ! update beginning time of next interval + startc(1) = 1 + startc(2) = start + countc(1) = 8 + countc(2) = 1 + call datetime (cdate, ctime) + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + ierr = pio_put_var (this%hist_files(split_file_index), this%date_writtenid, startc, countc, (/cdate/)) + ierr = pio_put_var (this%hist_files(split_file_index), this%time_writtenid, startc, countc, (/ctime/)) + end if + end do + + ! peverwhee - TODO handle composed fields + + call t_startf ('write_field') + do field_idx = 1, size(this%field_list) + do split_file_index = 1, max_split_files + if (.not. pio_file_is_open(this%hist_files(split_file_index))) then + cycle + end if + ! we may have a history split, conditionally skip fields that are + ! for the other file + if ((this%field_list(field_idx)%accumulate_type() .eq. 'lst') .and. & + split_file_index == accumulated_file_index .and. .not. restart) then + cycle + else if ((this%field_list(field_idx)%accumulate_type() .ne. 'lst') .and. & + split_file_index == instantaneous_file_index .and. .not. restart) then + cycle + end if + call this%write_field(field_idx, split_file_index, restart) + end do + end do + call t_stopf ('write_field') + + end subroutine config_write_time_dependent_variables + + ! ======================================================================== + + subroutine config_write_field(this, field_index, split_file_index, restart) + use pio, only: PIO_OFFSET_KIND, pio_setframe + use cam_history_support, only: hist_coords + use hist_buffer, only: hist_buffer_t, hist_buff_2dreal64_t, hist_buff_2dreal32_t + use hist_api, only: hist_buffer_norm_value + use cam_grid_support, only: cam_grid_write_dist_array + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: field_index + integer, intent(in) :: split_file_index + logical, intent(in) :: restart + + ! Local variables + integer, allocatable :: field_shape(:) ! Field file dim sizes + integer :: frank ! Field file rank + !type(dim_index_2d) :: dimind2 ! 2-D dimension index + !type(dim_index_3d) :: dimind ! 3-D dimension index + integer, allocatable :: dimind(:) + integer, allocatable :: dim_sizes(:) + integer, allocatable :: beg_dims(:) + integer, allocatable :: end_dims(:) + integer :: patch_idx, num_patches + type(var_desc_t) :: varid + integer :: samples_on_file + integer :: field_decomp + integer :: num_dims + integer :: idx + logical :: index_map(3) + real(REAL32), allocatable :: field_data(:,:) + class(hist_buffer_t), pointer :: buff_ptr + class(hist_buff_2dreal64_t), pointer :: buff_ptr_2d + class(hist_buff_2dreal32_t), pointer :: buff_ptr_2d_32 + + !!! Get the field's shape and decomposition + ! Shape on disk + call this%field_list(field_index)%shape(field_shape) + frank = size(field_shape) + allocate(field_data(field_shape(1), field_shape(2))) + ! Shape of array + call this%field_list(field_index)%dimensions(dimind) + + call this%field_list(field_index)%beg_dims(beg_dims) + call this%field_list(field_index)%end_dims(end_dims) + allocate(dim_sizes(size(beg_dims))) + do idx = 1, size(beg_dims) + dim_sizes(idx) = end_dims(idx) - beg_dims(idx) + 1 + end do + num_dims = 0 + index_map = .false. + do idx = 1, size(beg_dims) + if ((end_dims(idx) - beg_dims(idx)) > 1) then + num_dims = num_dims + 1 + index_map(idx) = .true. + end if + end do + field_decomp = this%field_list(field_index)%decomp() + + num_patches = 1 + samples_on_file = mod(this%num_samples, this%max_frames) + + do patch_idx = 1, num_patches + varid = this%field_list(field_index)%varid(patch_idx) + call pio_setframe(this%hist_files(split_file_index), varid, int(max(1,samples_on_file),kind=PIO_OFFSET_KIND)) + buff_ptr => this%field_list(field_index)%buffers + call hist_buffer_norm_value(buff_ptr, field_data) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & + field_shape(1:frank), field_data, varid) + end do + + end subroutine config_write_field + + ! ======================================================================== + + subroutine config_close_files(this) + use pio, only: pio_file_is_open + use cam_pio_utils, only: cam_pio_closefile + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + + ! Local variables + integer :: split_file_index, field_index + + if (masterproc) then + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + write(iulog,*)'config_close_files: nf_close(', this%volume,')=',& + this%file_names(split_file_index) + end if + end do + end if + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + call cam_pio_closefile(this%hist_files(split_file_index)) + end if + end do + if(pio_file_is_open(this%hist_files(accumulated_file_index)) .or. & + pio_file_is_open(this%hist_files(instantaneous_file_index))) then + do field_index = 1, size(this%field_list) + call this%field_list(field_index)%reset_varid() + end do + end if + if (allocated(this%file_names)) then + deallocate(this%file_names) + end if + + end subroutine config_close_files + + ! ======================================================================== + integer function count_array(arr_in) ! Dummy argument character(len=*), intent(in) :: arr_in(:) @@ -338,7 +1614,6 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & use mpi, only: MPI_CHARACTER, MPI_INTEGER, MPI_LOGICAL use shr_kind_mod, only: CL=>SHR_KIND_CL use string_utils, only: to_str - use cam_abortutils, only: endrun use spmd_utils, only: masterproc, masterprocid, mpicom use shr_nl_mod, only: shr_nl_find_group_name ! Read a history file configuration from and process it into @@ -363,11 +1638,13 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & logical :: hist_collect_patch_output character(len=flen) :: hist_file_type character(len=CL) :: hist_filename_spec + logical :: hist_write_nstep0 ! Local variables (other) integer :: ierr integer :: num_fields integer :: file_type integer :: rl_kind + logical :: has_acc ! XXgoldyXX: Add patch information logical :: hist_interp_out integer :: hist_interp_nlat @@ -381,7 +1658,8 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_precision, hist_max_frames, hist_output_frequency, & hist_file_type, hist_collect_patch_output, & hist_interp_out, hist_interp_nlat, hist_interp_nlon, & - hist_interp_grid, hist_interp_type, hist_filename_spec + hist_interp_grid, hist_interp_type, hist_filename_spec, & + hist_write_nstep0 ! Initialize namelist entries to default values hist_inst_fields(:) = '' @@ -402,22 +1680,24 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_interp_type = UNSET_C file_type = hfile_type_default hist_filename_spec = UNSET_C - write(iulog,*) 'reading in hist_file_config_nl' + hist_write_nstep0 = .false. + + has_acc = .false. ! Read namelist entry if (masterproc) then - rewind(unitn) - call shr_nl_find_group_name(unitn, 'hist_file_config_nl', ierr) - if (ierr == 0) then - read(unitn, hist_file_config_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname//"ERROR "//trim(to_str(ierr))// & - " reading namelist", file=__FILE__, line=__LINE__) - end if - else - write(iulog,*) ierr - write(iulog, *) subname, ": WARNING, no hist_file_config_nl ", & - "namelist found" +! rewind(unitn) +! call shr_nl_find_group_name(unitn, 'hist_file_config_nl', ierr) +! if (ierr == 0) then + read(unitn, hist_file_config_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname//"ERROR "//trim(to_str(ierr))// & + " reading namelist", file=__FILE__, line=__LINE__) end if +! else +! write(iulog,*) ierr +! write(iulog, *) subname, ": WARNING, no hist_file_config_nl ", & +! "namelist found" +! end if ! Translate select case(trim(hist_file_type)) case(UNSET_C, 'history') @@ -452,26 +1732,31 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & end if num_fields = count_array(hist_avg_fields) if (num_fields > 0) then + has_acc = .true. call MPI_Bcast(hist_avg_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_min_fields) if (num_fields > 0) then + has_acc = .true. call MPI_Bcast(hist_min_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_max_fields) if (num_fields > 0) then + has_acc = .true. call MPI_Bcast(hist_max_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_var_fields) if (num_fields > 0) then + has_acc = .true. call MPI_Bcast(hist_var_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if call MPI_Bcast(hist_volume, vlen, MPI_CHARACTER, masterprocid, & mpicom, ierr) + call MPI_Bcast(rl_kind, 1, MPI_INTEGER, masterprocid, mpicom, ierr) call MPI_Bcast(hist_max_frames, 1, MPI_INTEGER, masterprocid, & mpicom, ierr) @@ -489,9 +1774,12 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & ! Configure the history file call hfile_config%configure(hist_volume, rl_kind, hist_max_frames, & hist_output_frequency, file_type, hist_filename_spec, & - hist_collect_patch_output, interp_out=hist_interp_out, & + hist_collect_patch_output, hist_inst_fields, hist_avg_fields, & + hist_min_fields, hist_max_fields, hist_var_fields, & + hist_write_nstep0, interp_out=hist_interp_out, & interp_nlat=hist_interp_nlat, interp_nlon=hist_interp_nlon, & - interp_grid=hist_interp_grid, interp_type=hist_interp_type) + interp_grid=hist_interp_grid, interp_type=hist_interp_type, & + split_file=has_acc) call hfile_config%print_config() end subroutine read_namelist_entry @@ -503,11 +1791,9 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & use mpi, only: MPI_INTEGER use shr_kind_mod, only: SHR_KIND_CL use shr_nl_mod, only: shr_nl_find_group_name - use cam_abortutils, only: endrun use string_utils, only: to_str use cam_logfile, only: iulog use spmd_utils, only: mpicom, masterproc, masterprocid - use cam_abortutils, only: endrun, check_allocate ! Read the maximum sizes of field arrays from namelist file and allocate ! field arrays ! Dummy arguments @@ -552,7 +1838,6 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & if (allocated(hist_var_fields)) then deallocate(hist_var_fields) end if - write(iulog,*) 'reading hist_config_arrays_nl' if (masterproc) then rewind(unitn) call shr_nl_find_group_name(unitn, 'hist_config_arrays_nl', ierr) @@ -601,11 +1886,10 @@ end subroutine allocate_field_arrays ! ======================================================================== - function hist_read_namelist_config(filename) result(config_arr) + subroutine hist_read_namelist_config(filename, config_arr) use mpi, only: MPI_CHARACTER, MPI_INTEGER use shr_kind_mod, only: max_str =>SHR_KIND_CXX, SHR_KIND_CS, SHR_KIND_CL use shr_nl_mod, only: shr_nl_find_group_name - use cam_abortutils, only: endrun, check_allocate use spmd_utils, only: masterproc, masterprocid, mpicom use string_utils, only: to_str ! Read all the history configuration namelist groups from @@ -615,7 +1899,7 @@ function hist_read_namelist_config(filename) result(config_arr) ! Dummy arguments character(len=*), intent(in) :: filename - type(hist_file_t), pointer :: config_arr(:) + type(hist_file_t), allocatable, intent(inout) :: config_arr(:) ! Local variables integer :: unitn integer :: read_status @@ -634,7 +1918,7 @@ function hist_read_namelist_config(filename) result(config_arr) character(len=*), parameter :: subname = 'read_config_file' ! Variables for reading a namelist entry - nullify(config_arr) +! nullify(config_arr) unitn = -1 ! Prevent reads on error or wrong tasks ierr = 0 errmsg = '' @@ -764,6 +2048,40 @@ function hist_read_namelist_config(filename) result(config_arr) if (allocated(hist_var_fields)) then deallocate(hist_var_fields) end if - end function hist_read_namelist_config + end subroutine hist_read_namelist_config + + character(len=max_fldlen) function strip_suffix (name) + ! + !---------------------------------------------------------- + ! + ! Purpose: Strip "&IC" suffix from fieldnames if it exists + ! + !---------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: name + ! + ! Local workspace + ! + integer :: n + ! + !----------------------------------------------------------------------- + ! + strip_suffix = ' ' + + do n = 1,fieldname_len + strip_suffix(n:n) = name(n:n) + if(name(n+1:n+1 ) == ' ' ) return + if(name(n+1:n+fieldname_suffix_len) == fieldname_suffix) return + end do + + strip_suffix(fieldname_len+1:max_fldlen) = name(fieldname_len+1:max_fldlen) + + ! return + + end function strip_suffix + + !####################################################################### end module cam_hist_file diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 036318c4..436ba0a4 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -16,6 +16,7 @@ module cam_history ! cam_hist_write_history_files !----------------------------------------------------------------------- + use ISO_FORTRAN_ENV, only: REAL64, REAL32, INT32, INT64 use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX use shr_sys_mod, only: shr_sys_flush @@ -27,7 +28,15 @@ module cam_history use cam_abortutils, only: endrun use cam_logfile, only: iulog use cam_hist_file, only: hist_file_t - use cam_history_support, only: pfiles + use cam_grid_support, only: max_split_files + use cam_hist_file, only: instantaneous_file_index, accumulated_file_index + use cam_hist_file, only: strip_suffix + use cam_history_support, only: pfiles, horiz_only + use cam_history_support, only: max_fldlen=>max_fieldname_len, max_chars, fieldname_len + use hist_field, only: hist_field_info_t + use hist_hash_table, only: hist_hash_table_t + use hist_hashable, only: hist_hashable_t + use time_manager, only: get_nstep implicit none private @@ -61,8 +70,11 @@ module cam_history ! public :: history_init_restart ! Write restart history data ! public :: history_write_restart ! Write restart history data ! public :: history_read_restart ! Read restart history data -! public :: history_write_files ! Write files out -! public :: cam_hist_init_files ! Initialization + public :: history_write_files ! Write files out + public :: history_init_files ! Initialization + public :: history_add_field ! Write to list of possible history fields for this run + public :: history_out_field ! Accumulate field if its in use by one or more tapes + public :: history_wrap_up ! Process history files at end of timestep or run ! public :: history_finalize ! process history files at end of run ! public :: history_write_IC ! flag to dump of IC to IC file ! public :: history_define_fld ! Add a field to history file @@ -71,8 +83,22 @@ module cam_history ! public :: history_fld_col_active ! .true. for each column where a field is active on any history file ! public :: register_vector_field ! Register vector field set for interpolated output + interface history_out_field + module procedure history_out_field_1d + module procedure history_out_field_2d + module procedure history_out_field_3d + end interface history_out_field + + interface history_add_field + module procedure history_add_field_1d + module procedure history_add_field_nd + end interface history_add_field + ! Private data - type(hist_file_t), pointer :: hist_configs(:) + type(hist_file_t), allocatable :: hist_configs(:) + type(hist_field_info_t), pointer :: possible_field_list_head + type(hist_hash_table_t) :: possible_field_list + integer :: num_possible_fields CONTAINS @@ -93,13 +119,7 @@ subroutine history_readnl(nlfile) character(len=512) :: test_msg ! Read in CAM history configuration - hist_configs => hist_read_namelist_config(nlfile) - write(iulog,*) 'peverwhee' - write(iulog,*) hist_configs(1)%filename() - !if (check_endrun(test_desc=test_msg, output=out_unit)) then - ! err_cnt = err_cnt + 1 - !end if - ! + call hist_read_namelist_config(nlfile, hist_configs) ! Setup the interpolate_info structures !do t = 1, size(interpolate_info) @@ -116,4 +136,706 @@ end subroutine history_readnl !=========================================================================== + subroutine history_write_files() + use time_manager, only: set_date_from_time_float + character(len=cl) :: file_names(max_split_files) + character(len=cl) :: prev_file_names(max_split_files) + integer :: yr, mon, day + integer :: yr_mid, mon_mid, day_mid + integer :: nstep + integer :: ncdate, ncdate_mid + integer :: ncsec, ncsec_mid + integer :: ndcur, nscur + integer :: num_samples + real(r8) :: time, beg_time + real(r8) :: time_interval(2) + integer :: file_idx, split_file_idx, prev_file_idx, idx + integer :: out_frq_mult + character(len=8) :: out_frq_type + logical :: write_history, write_nstep0, duplicate + character(len=cl) :: filename_spec, prev_filename_spec + integer :: start, count1 + logical :: restart + + ! Get nstep + nstep = get_nstep() + + ! peverwhee - TODO: remove when restarts are implemented + restart = .false. + + ! Loop over history volumes + do file_idx = 1, size(hist_configs) + ! Determine if it's time to write! + write_history = .false. + call hist_configs(file_idx)%output_freq_separate(out_frq_mult, out_frq_type) + select case(trim(out_frq_type)) + case('step') + if (mod(nstep, out_frq_mult) == 0) then + write_history = .true. + end if + case('second') + if (mod(ncsec, out_frq_mult) == 0) then + write_history = .true. + end if + case('minute') + if (mod(ncsec, out_frq_mult * 60) == 0) then + write_history = .true. + end if + case('hour') + if (mod(ncsec, out_frq_mult * 3600) == 0) then + write_history = .true. + end if + case('day') + if (mod(day, out_frq_mult) == 0 .and. ncsec == 0) then + write_history = .true. + end if + case('month') + if (mod(mon, out_frq_mult) == 0 .and. ncsec == 0 .and. day == 1) then + write_history = .true. + end if + case('year') + if (mod(yr, out_frq_mult) == 0 .and. ncsec == 0 .and. day == 1 .and. & + mon == 1) then + write_history = .true. + end if + end select + if (.not. write_history) then + ! Don't write this volume! + cycle + end if + write_nstep0 = hist_configs(file_idx)%do_write_nstep0() + if (nstep == 0 .and. .not. write_nstep0) then + ! Don't write the first step + cycle + end if + num_samples = hist_configs(file_idx)%get_num_samples() + if (mod(num_samples, hist_configs(file_idx)%max_frame()) == 0) then + ! This if the first write to this file - set up volume + call hist_configs(file_idx)%set_filenames() + file_names = hist_configs(file_idx)%get_filenames() + duplicate = .false. + do prev_file_idx = 1, file_idx - 1 + prev_file_names = hist_configs(prev_file_idx)%filename() + do idx = 1, max_split_files + if (prev_file_names(idx) == file_names(idx)) then + duplicate = .true. + write(iulog,*)'hist_write_files: New filename same as old file = ', trim(file_names(idx)) + end if + end do + end do + if (duplicate) then + filename_spec = hist_configs(file_idx)%get_filename_spec() + prev_filename_spec = hist_configs(prev_file_idx)%get_filename_spec() + write(iulog,*)'Is there an error in your filename specifiers?' + write(iulog,*)'filename_spec(', file_idx, ') = ', trim(filename_spec) + if ( prev_file_idx /= file_idx )then + write(iulog,*)'filename_spec(', prev_file_idx, ') = ', trim(prev_filename_spec) + end if + call endrun('hist_write_files: ERROR - see atm log file for information') + end if + call hist_configs(file_idx)%define_file(restart, logname, host, model_doi_url) + ! call hist_configs(file_idx)%write_time_dependent_variables(file_idx, restart) + end if + call hist_configs(file_idx)%write_time_dependent_variables(file_idx, restart) + end do + + end subroutine history_write_files + + !=========================================================================== + + subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) + + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Initialize history file handler for initial or continuation + ! run. + ! For example, on an initial run, this routine initializes + ! the configured history files. On a restart run, this routine + ! only initializes history files declared beyond what existed + ! on the previous run. Files which already existed on the + ! previous run have already been initialized (i.e. named and + ! opened) in routine, hist_initialize_restart + ! + !----------------------------------------------------------------------- + use shr_sys_mod, only: shr_sys_getenv + use time_manager, only: get_prev_time, get_curr_time +! use cam_control_mod, only: restart_run, branch_run +! use sat_hist, only: sat_hist_init + use spmd_utils, only: mpicom, masterprocid + use mpi, only: mpi_character + ! + !----------------------------------------------------------------------- + ! + ! Dummy argument + ! + character(len=cl), intent(in) :: model_doi_url_in + character(len=cl), intent(in) :: caseid_in + character(len=cl), intent(in) :: ctitle_in + ! + ! Local workspace + ! + integer :: fil_idx, fld_ind ! file, field indices + integer :: begdim1 ! on-node dim1 start index + integer :: enddim1 ! on-node dim1 end index + integer :: begdim2 ! on-node dim2 start index + integer :: enddim2 ! on-node dim2 end index + integer :: begdim3 ! on-node chunk or lat start index + integer :: enddim3 ! on-node chunk or lat end index + integer :: day, sec ! day and seconds from base date + integer :: rcode ! shr_sys_getenv return code +! type(master_entry), pointer :: listentry + character(len=32) :: fldname + + ! + ! Save the DOI + ! + model_doi_url = trim(model_doi_url_in) + caseid = caseid_in + ctitle = ctitle_in + + ! Print out the list of possible fields + call print_field_list() + + ! Set up possible field list hash table + call possible_field_list%initialize(num_possible_fields) + call set_up_field_list_hash_table() + + ! + ! Get users logname and machine hostname + ! + if (masterproc) then + logname = ' ' + call shr_sys_getenv ('LOGNAME', logname, rcode) + host = ' ' + call shr_sys_getenv ('HOST', host, rcode) + end if + ! PIO requires netcdf attributes have consistant values on all tasks + call mpi_bcast(logname, len(logname), mpi_character, & + masterprocid, mpicom, rcode) + call mpi_bcast(host, len(host), mpi_character, & + masterprocid, mpicom, rcode) + + ! peverwhee - override averaging flag if specified? + +! if (branch_run) then +! call get_prev_time(day, sec) ! elapased time since reference date +! else + call get_curr_time(day, sec) ! elapased time since reference date +! end if + + do fil_idx = 1, size(hist_configs, 1) + ! Time at beginning of current averaging interval. + call hist_configs(fil_idx)%set_beg_time(day, sec) + + ! Set up fields and buffers + call hist_configs(fil_idx)%set_up_fields(possible_field_list) + end do + + + end subroutine history_init_files + + !=========================================================================== + + subroutine print_field_list() + ! Local variables + class(hist_hashable_t), pointer :: field_ptr_value + class(hist_field_info_t), pointer :: field_ptr + + character(len=4) :: avgflag + + field_ptr => possible_field_list_head + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*)' ***************** HISTORY FIELD LIST ******************' + end if + do + if (associated(field_ptr)) then + avgflag = field_ptr%accumulate_type() + if (avgflag == 'lst') then + avgflag = 'inst' + end if + if (masterproc) then + write(iulog, 9000) trim(field_ptr%diag_name()), & + field_ptr%units(), avgflag, & + field_ptr%standard_name() +9000 format(a16, 1x, a12, 2x, a3, 2x, a) + end if + field_ptr => field_ptr%next + else + exit + end if + end do + if (masterproc) then + write(iulog,*)' *************** END HISTORY FIELD LIST ****************' + write(iulog,*) ' ' + end if + + end subroutine print_field_list + +!=========================================================================== + + subroutine set_up_field_list_hash_table() + ! Local variables + class(hist_field_info_t), pointer :: field_ptr + + field_ptr => possible_field_list_head + + if (associated(field_ptr)) then + ! Add to end of field list + do + call possible_field_list%add_hash_key(field_ptr) + if (associated(field_ptr%next)) then + field_ptr => field_ptr%next + else + exit + end if + end do + end if + + end subroutine set_up_field_list_hash_table + +!=========================================================================== + + subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & + avgflag, units, gridname) + use cam_history_support, only: get_hist_coord_index + ! + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the master field list + ! + ! Method: Put input arguments of field name, units, number of levels, + ! averaging flag, and long name into a type entry in the global + ! master field list (masterlist). + ! + !----------------------------------------------------------------------- + + ! + ! Arguments + ! + character(len=*), intent(in) :: diagnostic_name ! field name (max_fieldname_len) + character(len=*), intent(in) :: standard_name ! field standard name + character(len=*), intent(in) :: vdim_name ! NetCDF dimension name (or scalar coordinate) + character(len=*), intent(in) :: avgflag ! averaging flag + character(len=*), intent(in) :: units ! units of fname (max_chars) + character(len=*), optional, intent(in) :: gridname + + ! + ! Local workspace + ! + character(len=max_chars), allocatable :: dimnames(:) + integer :: index + + if (trim(vdim_name) == trim(horiz_only)) then + allocate(dimnames(0)) + else + index = get_hist_coord_index(trim(vdim_name)) + if (index < 1) then + call endrun('history_add_field_1d: Invalid coordinate, '//trim(vdim_name)) + end if + allocate(dimnames(1)) + dimnames(1) = trim(vdim_name) + end if + call history_add_field(diagnostic_name, standard_name, dimnames, avgflag, units, gridname) + + end subroutine history_add_field_1d + +!=========================================================================== + + subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgflag, & + units, gridname, flag_xyfill) + ! Add field to possible field linked list + use hist_api, only: hist_new_field + use hist_hashable, only: hist_hashable_char_t + use hist_hashable, only: hist_hashable_int_t + use cam_grid_support, only: cam_grid_get_coord_names + use cam_grid_support, only: cam_grid_dimensions + use cam_grid_support, only: cam_grid_id, cam_grid_is_zonal + use cam_grid_support, only: cam_grid_get_array_bounds + use cam_history_support, only: lookup_hist_coord_indices + use cam_history_support, only: hist_coord_find_levels, hist_coords + !use cam_ccpp_cap, only: cam_const_get_index + + character(len=*), intent(in) :: diagnostic_name + character(len=*), intent(in) :: standard_name + character(len=*), intent(in) :: dimnames(:) + character(len=*), intent(in) :: avgflag ! averaging flag + character(len=*), intent(in) :: units ! units of fname (max_chars) + character(len=*), optional, intent(in) :: gridname + logical, optional, intent(in) :: flag_xyfill + + ! Local variables + class(hist_field_info_t), pointer :: field_ptr + class(hist_field_info_t), pointer :: listentry + integer :: grid_decomp, rank, pos + integer :: grid_dims(2) + integer :: dimcnt, num_levels + integer, allocatable :: mdim_indices(:) + integer, allocatable :: mdim_sizes(:) + integer, allocatable :: field_shape(:) + integer :: const_index + integer :: errcode + integer :: dimbounds(2,2) + character(len=512) :: errmsg + character(len=max_fldlen) :: fname_tmp ! local copy of fname + character(len=max_fldlen) :: coord_name ! for cell_methods + character(len=max_fldlen) :: cell_methods + character(len=3) :: mixing_ratio + + if (size(hist_configs) > 0 .and. hist_configs(1)%file_is_setup()) then + call endrun ('history_add_field_nd: Attempt to add field '//trim(diagnostic_name)//' after history files set') + end if + + ! Some checks for diagnostic_name + ! + ! Ensure that the diagnostic name is not blank + ! + if (len_trim(diagnostic_name)==0) then + call endrun('history_add_field_nd: blank field name not allowed') + end if + ! + ! Ensure that new field name is not longer than allowed + ! (strip "&IC" suffix if it exists) + ! + fname_tmp = diagnostic_name + fname_tmp = strip_suffix(fname_tmp) + + if (len_trim(fname_tmp) > fieldname_len) then + write(iulog,*)'history_add_field_nd: field name cannot be longer than ', fieldname_len,' characters long' + write(iulog,*)'Field name: ',diagnostic_name + write(errmsg, *) 'Field name, "', trim(diagnostic_name), '" is too long' + call endrun('history_add_field_nd: '//trim(errmsg)) + end if + + ! + ! Ensure that new field doesn't already exist + ! + listentry => get_entry_by_name(possible_field_list_head, diagnostic_name) + if(associated(listentry)) then + call endrun ('history_add_field_nd: '//diagnostic_name//' already on list') + end if + + ! If the field is an advected constituent determine whether its concentration + ! is based on dry or wet air. + ! peverwhee - TODO: constituents handling requires SIMA and/or framework update + !call cam_const_get_index(standard_name, const_index, errcode, errmsg) + !if (errcode /= 0) then + ! write(iulog,*) errmsg + ! call endrun('history_add_field_nd: '//diagnostic_name//' failed in const_get_index') + !end if + mixing_ratio = '' + !if (const_index > 0) then + ! mixing_ratio = cnst_get_type_byind(idx) + !end if + + + if (present(gridname)) then + grid_decomp = cam_grid_id(trim(gridname)) + else + ! default to physics grid + grid_decomp = cam_grid_id('physgrid') + end if + if (grid_decomp < 0) then + write(errmsg, *) 'Invalid grid name, "', trim(gridname), '" for ', trim(diagnostic_name) + call endrun('history_add_field_nd: '//trim(errmsg)) + end if + + ! Indicate if some field pre-processing occurred (e.g., zonal mean) + if (cam_grid_is_zonal(grid_decomp)) then + call cam_grid_get_coord_names(grid_decomp, coord_name, errmsg) + ! Zonal method currently hardcoded to 'mean'. + cell_methods = trim(coord_name)//': mean' + else + cell_methods = '' + end if + + ! peverwhee - TODO: handle fill values + + allocate(mdim_indices(size(dimnames, 1))) + + call lookup_hist_coord_indices(dimnames, mdim_indices) + + ! levels + num_levels = hist_coord_find_levels(dimnames) + if (num_levels < 0) then + num_levels = 1 + end if + + call cam_grid_get_array_bounds(grid_decomp, dimbounds) + + call cam_grid_dimensions(grid_decomp, grid_dims, rank) + pos = rank + if (size(mdim_indices) > 0) then + rank = rank + size(mdim_indices) + end if + allocate(field_shape(rank)) + allocate(mdim_sizes(size(mdim_indices))) + field_shape(1:pos) = grid_dims(1:pos) + if (rank > pos) then + do idx = 1, size(mdim_indices) + pos = pos + 1 + mdim_sizes(idx) = hist_coords(mdim_indices(idx))%dimsize + field_shape(pos) = mdim_sizes(idx) + end do + end if + + field_ptr => possible_field_list_head + if (associated(field_ptr)) then + ! Add to end of field list + do + if (associated(field_ptr%next)) then + field_ptr => field_ptr%next + else + field_ptr%next => hist_new_field(diagnostic_name, & + standard_name, standard_name, units, 'real', grid_decomp, & + mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio, & + dim_bounds=dimbounds, mdim_sizes=mdim_sizes, cell_methods=cell_methods, & + flag_xyfill=flag_xyfill) + exit + end if + end do + else + possible_field_list_head => hist_new_field(diagnostic_name, & + standard_name, standard_name, units, 'real', grid_decomp, & + mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio, & + dim_bounds=dimbounds, mdim_sizes=mdim_sizes, cell_methods=cell_methods, & + flag_xyfill=flag_xyfill) + end if + + num_possible_fields = num_possible_fields + 1 + + end subroutine history_add_field_nd + +!=========================================================================== + + subroutine history_out_field_1d(diagnostic_name, field_values, idim) + use hist_api, only: hist_field_accumulate + ! Dummy variables + character(len=*), intent(in) :: diagnostic_name + integer, intent(in) :: idim + real(r8), intent(in) :: field_values(:) + + ! Local variables + integer :: file_idx, field_idx + character(len=3) :: flag + logical :: found + character(len=cl) :: errmsg + character(len=*), parameter :: subname = 'history_out_field_1d: ' + class(hist_field_info_t), pointer :: field_info + + errmsg = '' + + ! peverwhee - TODO + ! - fill values + ! - different dimensions + + do file_idx = 1, size(hist_configs, 1) + ! Check if the field is on the current file + call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) + if (len_trim(errmsg) /= 0) then + call endrun('ERROR: '//subname//errmsg,file=__FILE__, line=__LINE__) + end if + if (.not. associated(field_info)) then + ! field is not active on this tape - do nothing! + cycle + end if + ! Field is active on this file - accumulate! + ! Accumulate the field + call hist_field_accumulate(field_info, real(field_values, REAL64), 1) + + end do + + end subroutine history_out_field_1d + +!=========================================================================== + + subroutine history_out_field_2d(diagnostic_name, field_values, idim) + use hist_api, only: hist_field_accumulate + use hist_msg_handler, only: hist_log_messages + ! Dummy variables + character(len=*), intent(in) :: diagnostic_name + integer, intent(in) :: idim + real(r8), intent(in) :: field_values(:,:) + type(hist_log_messages) :: logger + + ! Local variables + integer :: file_idx, field_idx + character(len=3) :: flag + logical :: found + character(len=cl) :: errmsg + character(len=*), parameter :: subname = 'history_out_field_2d: ' + class(hist_field_info_t), pointer :: field_info + + errmsg = '' + + ! peverwhee - TODO + ! - fill values + ! - different dimensions + + do file_idx = 1, size(hist_configs, 1) + ! Check if the field is on the current file + call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) + if (len_trim(errmsg) /= 0) then + call endrun('ERROR: '//subname//errmsg,file=__FILE__, line=__LINE__) + end if + if (.not. associated(field_info)) then + ! field is not active on this tape - do nothing! + cycle + end if + ! Field is active on this file - accumulate! + ! Accumulate the field + call hist_field_accumulate(field_info, real(field_values, REAL32), 1, logger=logger) + call logger%output(iulog) + + end do + + end subroutine history_out_field_2d + +!=========================================================================== + + subroutine history_out_field_3d(diagnostic_name, field_values, idim) + use hist_api, only: hist_field_accumulate + ! Dummy variables + character(len=*), intent(in) :: diagnostic_name + integer, intent(in) :: idim + real(r8), intent(in) :: field_values(:,:,:) + + ! Local variables + integer :: file_idx, field_idx + character(len=3) :: flag + logical :: found + character(len=cl) :: errmsg + character(len=*), parameter :: subname = 'history_out_field_3d: ' + class(hist_field_info_t), pointer :: field_info + + errmsg = '' + + ! peverwhee - TODO + ! - fill values + ! - different dimensions + + do file_idx = 1, size(hist_configs, 1) + ! Check if the field is on the current file + call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) + if (len_trim(errmsg) /= 0) then + call endrun('ERROR: '//subname//errmsg,file=__FILE__, line=__LINE__) + end if + if (.not. associated(field_info)) then + ! field is not active on this tape - do nothing! + cycle + end if + ! Field is active on this file - accumulate! + ! Accumulate the field + !call hist_field_accumulate(field_info, real(field_values, REAL64), 1) + + end do + + end subroutine history_out_field_3d + +!========================================================================== + + subroutine history_wrap_up(restart_write, last_timestep) + use time_manager, only: get_curr_date, get_curr_time + ! + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Close history files. + ! + ! Method: + ! This routine will close any full hist. files + ! or any hist. file that has data on it when restart files are being + ! written. + ! If a partially full history file was disposed (for restart + ! purposes), then wrapup will open that unit back up and position + ! it for appending new data. + ! + ! Original version: CCM2 + ! + !----------------------------------------------------------------------- + ! + ! Dummy arguments + logical, intent(in) :: restart_write + logical, intent(in) :: last_timestep + + ! Local variables + integer :: yr, mon, day, ncsec + integer :: ndcur, nscur, nstep + integer :: file_idx, split_file_idx, field_idx + integer :: num_samples, max_frames + logical :: full + real(r8) :: tday ! Model day number for printout + + nstep = get_nstep() + call get_curr_date(yr, mon, day, ncsec) + call get_curr_time(ndcur, nscur) + ! + !----------------------------------------------------------------------- + ! Dispose history files. + !----------------------------------------------------------------------- + ! + ! Begin loop over hist_configs (the no. of declared history files - primary + ! and auxiliary). This loop disposes a history file to Mass Store + ! when appropriate. + ! + + do file_idx = 1, size(hist_configs) + ! + ! Find out if file is full + ! + full = .false. + num_samples = hist_configs(file_idx)%get_num_samples() + max_frames = hist_configs(file_idx)%max_frame() + if (mod(num_samples, max_frames) == 0) then + full = .true. + end if + if (full .or. (last_timestep .and. num_samples >= 1)) then + ! + ! Dispose history file + ! + call hist_configs(file_idx)%close_files() + + ! + ! Print information concerning model output. + ! Model day number = iteration number of history file data * delta-t / (seconds per day) + ! + tday = ndcur + nscur/86400._r8 + if(masterproc) then + if (file_idx == 1) then + write(iulog,*)' Primary history file' + else + write(iulog,*)' Auxiliary history file number ', file_idx-1 + end if + write(iulog,9003)nstep,mod(num_samples, max_frames),tday + write(iulog,9004) + end if + end if + end do +9003 format(' Output at NSTEP = ',i10,/, & + ' Number of time samples on this file = ',i10,/, & + ' Model Day = ',f10.2) +9004 format('---------------------------------------') + + end subroutine history_wrap_up + +!####################################################################### + + recursive function get_entry_by_name(listentry, name) result(entry) + type(hist_field_info_t), pointer :: listentry + character(len=*), intent(in) :: name ! variable name + type(hist_field_info_t), pointer :: entry + + if(associated(listentry)) then + if(listentry%diag_name() .eq. name) then + entry => listentry + else + entry=>get_entry_by_name(listentry%next, name) + end if + else + nullify(entry) + end if + end function get_entry_by_name + end module cam_history diff --git a/src/history/cam_history_support.F90 b/src/history/cam_history_support.F90 index 4c3b8c84..42659d59 100644 --- a/src/history/cam_history_support.F90 +++ b/src/history/cam_history_support.F90 @@ -7,7 +7,7 @@ module cam_history_support !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - use shr_kind_mod, only: r8=>shr_kind_r8 + use shr_kind_mod, only: r8=>shr_kind_r8, shr_kind_cl, shr_kind_cxx use pio, only: var_desc_t, file_desc_t, PIO_MAX_NAME use cam_abortutils, only: endrun use cam_logfile, only: iulog @@ -20,11 +20,64 @@ module cam_history_support private save - ! max_fieldname_len = max chars for field name - integer, parameter, public :: max_fieldname_len = PIO_MAX_NAME + integer, parameter, public :: fieldname_len = 32 ! max chars for field name + integer, parameter, public :: fieldname_suffix_len = 3 ! length of field name suffix ("&IC") + ! max_fieldname_len = max chars for field name (including suffix) + integer, parameter, public :: max_fieldname_len = fieldname_len + fieldname_suffix_len ! default fill value for history NetCDF fields real(r8), parameter, public :: hist_default_fillvalue = 1.e36_r8 integer, parameter, public :: pfiles = 12 ! max number of tapes + integer, parameter, public :: max_chars = shr_kind_cl ! max chars for char variables + integer, parameter, public :: max_string_len = shr_kind_cxx + real(r8), parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields + ! A special symbol for declaring a field which has no vertical or + ! non-grid dimensions. It is here (rather than cam_history) so that it + ! be checked by add_hist_coord + character(len=10), parameter, public :: horiz_only = 'horiz_only' + + !--------------------------------------------------------------------------- + ! + ! formula_terms_t: Information for formula terms (CF convention) variables + ! Used to add a formula-terms variable to the history file + ! Also adds a string, ': ' to the parent + ! mdim's 'formula_terms' attribute. + ! + !--------------------------------------------------------------------------- + type, public :: formula_terms_t + character(len=max_fieldname_len) :: a_name = '' ! 'A' term variable name + character(len=max_string_len) :: a_long_name = '' ! 'A' long name + real(r8), pointer :: a_values(:) => null() ! 'A' variable values + character(len=max_fieldname_len) :: b_name = '' ! 'B' term variable name + character(len=max_string_len) :: b_long_name = '' ! 'B' long name + real(r8), pointer :: b_values(:) => null() ! 'B' variable values + character(len=max_fieldname_len) :: p0_name = '' ! 'p0' term variable name + character(len=max_string_len) :: p0_long_name = '' ! 'p0' long name + character(len=max_chars) :: p0_units = '' ! 'p0' variable units + real(r8) :: p0_value = fillvalue ! 'p0' variable values + character(len=max_fieldname_len) :: ps_name = '' ! 'ps' term variable name + end type formula_terms_t + + !--------------------------------------------------------------------------- + ! + ! hist_coord_t: Information for history variable dimension attributes + ! + !--------------------------------------------------------------------------- + type, public :: hist_coord_t + character(len=max_hcoordname_len) :: name = '' ! coordinate name + integer :: dimsize = 0 ! size of dimension + character(len=max_hcoordname_len) :: dimname = '' ! optional dimension name + character(len=max_chars) :: long_name = '' ! 'long_name' attribute + character(len=max_chars) :: units = '' ! 'units' attribute + character(len=max_chars) :: bounds_name = '' ! 'bounds' attribute (& name of bounds variable) + character(len=max_chars) :: standard_name = ''! 'standard_name' attribute + character(len=4) :: positive = '' ! 'positive' attribute ('up' or 'down') + integer, pointer :: integer_values(:) => null() ! dim values if integral + real(r8), pointer :: real_values(:) => null() ! dim values if real + real(r8), pointer :: bounds(:,:) => null() ! dim bounds + type(formula_terms_t) :: formula_terms ! vars for formula terms + logical :: integer_dim ! .true. iff dim has integral values + logical :: vertical_coord ! .true. iff dim is vertical + end type hist_coord_t ! Some parameters for use with interpolated output namelist items integer, parameter, public :: interp_type_native = 0 @@ -32,7 +85,6 @@ module cam_history_support integer, parameter, public :: interp_gridtype_equal_poles = 1 integer, parameter, public :: interp_gridtype_gauss = 2 integer, parameter, public :: interp_gridtype_equal_nopoles = 3 - !--------------------------------------------------------------------------- ! ! interp_info_t: Information for lat/lon interpolated history output @@ -56,4 +108,973 @@ module cam_history_support real(r8), pointer :: interp_gweight(:) => NULL() end type interp_info_t + !! Coordinate variables + integer, public :: registeredmdims = 0 + integer, public :: maxvarmdims = 1 + character(len=9), parameter, public :: mdim_var_name = 'mdimnames' + integer, parameter :: maxmdims = 25 ! arbitrary limit + type(hist_coord_t), public :: hist_coords(maxmdims) + + public :: write_hist_coord_attrs + public :: write_hist_coord_vars + public :: add_hist_coord, add_vert_coord + public :: lookup_hist_coord_indices + public :: hist_coord_find_levels + public :: get_hist_coord_index + + interface add_hist_coord + module procedure add_hist_coord_regonly + module procedure add_hist_coord_int + module procedure add_hist_coord_r8 + end interface + + interface check_hist_coord + ! NB: This is supposed to be a private interface + ! check_hist_coord: returns 0 if is not registered as an mdim + ! returns i if is registered with compatible values + ! calls endrun if is registered with incompatible values + ! Versions without the argument return .true. or .false. + module procedure check_hist_coord_char + module procedure check_hist_coord_int + module procedure check_hist_coord_int1 + module procedure check_hist_coord_r8 + module procedure check_hist_coord_r81 + module procedure check_hist_coord_r82 + module procedure check_hist_coord_ft + module procedure check_hist_coord_all + end interface + + !!--------------------------------------------------------------------------- + + CONTAINS + + integer function get_hist_coord_index(mdimname) + ! Input variables + character(len=*), intent(in) :: mdimname + ! Local variable + integer :: i + + get_hist_coord_index = -1 + do i = 1, registeredmdims + if(trim(mdimname) == trim(hist_coords(i)%name)) then + get_hist_coord_index = i + exit + end if + end do + + end function get_hist_coord_index + + + ! Functions to check consistent term definition for hist coords + logical function check_hist_coord_char(defined, input) + + ! Input variables + character(len=*), intent(in) :: defined + character(len=*), intent(in), optional :: input + + if (len_trim(defined) == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_char = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_char = (trim(input) == trim(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_char = .false. + end if + end function check_hist_coord_char + + logical function check_hist_coord_int(defined, input) + + ! Input variables + integer, intent(in) :: defined + integer, intent(in), optional :: input + + if (defined == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_int = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_int = (input == defined) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_int = .false. + end if + end function check_hist_coord_int + + logical function check_hist_coord_int1(defined, input) + + ! Input variables + integer, pointer :: defined(:) + integer, intent(in), optional :: input(:) + + ! Local variables + integer :: i + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_int1 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_int1 = (size(input) == size(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_int1 = .false. + end if + if (check_hist_coord_int1 .and. associated(defined)) then + ! Need to check the values + do i = 1, size(defined) + if (defined(i) /= input(i)) then + check_hist_coord_int1 = .false. + exit + end if + end do + end if + end function check_hist_coord_int1 + + logical function check_hist_coord_r8(defined, input) + + ! Input variables + real(r8), intent(in) :: defined + real(r8), intent(in), optional :: input + + if (defined == fillvalue) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r8 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r8 = (input == defined) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r8 = .false. + end if + end function check_hist_coord_r8 + + logical function check_hist_coord_r81(defined, input) + + ! Input variables + real(r8), pointer :: defined(:) + real(r8), intent(in), optional :: input(:) + + ! Local variables + integer :: i + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r81 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r81 = (size(input) == size(defined)) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r81 = .false. + end if + if (check_hist_coord_r81 .and. associated(defined)) then + ! Need to check the values + do i = 1, size(defined) + if (defined(i) /= input(i)) then + check_hist_coord_r81 = .false. + exit + end if + end do + end if + end function check_hist_coord_r81 + + logical function check_hist_coord_r82(defined, input) + + ! Input variables + real(r8), pointer :: defined(:,:) + real(r8), intent(in), optional :: input(:,:) + + ! Local variables + integer :: i, j + + if (.not. associated(defined)) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_r82 = .true. + else if (present(input)) then + ! We have to match definitions + check_hist_coord_r82 = ((size(input, 1) == size(defined, 1)) .and. & + (size(input, 2) == size(defined, 2))) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_r82 = .false. + end if + if (check_hist_coord_r82 .and. associated(defined)) then + ! Need to check the values + do j = 1, size(defined, 2) + do i = 1, size(defined, 1) + if (defined(i, j) /= input(i, j)) then + check_hist_coord_r82 = .false. + exit + end if + end do + end do + end if + end function check_hist_coord_r82 + + logical function check_hist_coord_ft(defined, input) + + ! Input variables + type(formula_terms_t), intent(in) :: defined + type(formula_terms_t), intent(in), optional :: input + + ! We will assume that if formula_terms has been defined, a_name has a value + if (len_trim(defined%a_name) == 0) then + ! In this case, we assume the current value is undefined so any input OK + check_hist_coord_ft = .true. + else if (present(input)) then + ! We have to match definitions + ! Need to check the values + check_hist_coord_ft = & + check_hist_coord(defined%a_name, input%a_name) .and. & + check_hist_coord(defined%a_long_name, input%a_long_name) .and. & + check_hist_coord(defined%a_values, input%a_values) .and. & + check_hist_coord(defined%b_name, input%b_name) .and. & + check_hist_coord(defined%b_long_name, input%b_long_name) .and. & + check_hist_coord(defined%b_values, input%b_values) .and. & + check_hist_coord(defined%p0_name, input%p0_name) .and. & + check_hist_coord(defined%p0_long_name, input%p0_long_name) .and. & + check_hist_coord(defined%p0_units, input%p0_units) .and. & + check_hist_coord(defined%p0_value, input%p0_value) .and. & + check_hist_coord(defined%ps_name, input%ps_name) + else + ! Not sure here. We have a value and are redefining without one? + check_hist_coord_ft = .false. + end if + end function check_hist_coord_ft + + ! check_hist_coord: returns 0 if is not registered as a hist coord + ! returns i if is registered with compatible values + ! calls endrun if is registered with incompatible + ! values + integer function check_hist_coord_all(name, vlen, long_name, units, bounds, & + i_values, r_values, bounds_name, positive, standard_name, formula_terms) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in), optional :: long_name + character(len=*), intent(in), optional :: units + character(len=*), intent(in), optional :: bounds_name + integer, intent(in), optional :: i_values(:) + real(r8), intent(in), optional :: r_values(:) + real(r8), intent(in), optional :: bounds(:,:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + type(formula_terms_t), intent(in), optional :: formula_terms + + ! Local variables + character(len=120) :: errormsg + integer :: i + + i = get_hist_coord_index(trim(name)) + ! If i > 0, this mdim has already been registered + if (i > 0) then + check_hist_coord_all = i + if (.not. check_hist_coord(hist_coords(i)%dimsize, vlen)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, '//trim(name)//' with incompatible size' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%long_name, long_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different long_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%units, units)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different units' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%bounds_name, bounds_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different bounds_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%standard_name, standard_name)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different standard_name' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%positive, positive)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different value of positive' + call endrun(errormsg) + end if + ! Since the integer_dim defaults to .true., double check which to check + if ((.not. hist_coords(i)%integer_dim) .or. & + associated(hist_coords(i)%real_values)) then + if (.not. check_hist_coord(hist_coords(i)%real_values, r_values)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values' + call endrun(errormsg) + else if (present(i_values)) then + write(errormsg, *) 'ERROR: Attempt to register integer values for real dimension' + call endrun(errormsg) + end if + else + if (.not. check_hist_coord(hist_coords(i)%integer_values, i_values)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values' + call endrun(errormsg) + else if (present(i_values) .and. present(r_values)) then + write(errormsg, *) 'ERROR: Attempt to register real values for integer dimension' + call endrun(errormsg) + end if + end if + if (.not. check_hist_coord(hist_coords(i)%bounds, bounds)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different bounds' + call endrun(errormsg) + end if + if (.not. check_hist_coord(hist_coords(i)%formula_terms, formula_terms)) then + write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different formula_terms' + call endrun(errormsg) + end if + else + check_hist_coord_all = 0 + end if + end function check_hist_coord_all + + subroutine add_hist_coord_regonly(name, index) + + ! Input variable + character(len=*), intent(in) :: name + integer, optional, intent(out) :: index + + ! Local variables + character(len=120) :: errormsg + integer :: i + + if ((trim(name) == trim(horiz_only)) .or. (len_trim(name) == 0)) then + call endrun('ADD_HIST_COORD: '//trim(name)//' is not a valid coordinate name') + end if + i = get_hist_coord_index(trim(name)) + ! If i > 0, this mdim has already been registered + if (i <= 0) then + registeredmdims = registeredmdims + 1 + if (registeredmdims > maxmdims) then + call endrun('Too many dimensions in add_hist_coord.') + end if + if (len_trim(name) > max_hcoordname_len) then + write(errormsg,'(a,i3,a)') 'History coord name exceeds the ', & + max_hcoordname_len, ' character length limit' + call endrun(errormsg) + end if + hist_coords(registeredmdims)%name = trim(name) + hist_coords(registeredmdims)%dimsize = 0 + hist_coords(registeredmdims)%long_name = '' + hist_coords(registeredmdims)%units = '' + hist_coords(registeredmdims)%integer_dim = .true. + hist_coords(registeredmdims)%positive = '' + hist_coords(registeredmdims)%standard_name = '' + if (present(index)) then + index = registeredmdims + end if + else + if (present(index)) then + index = i + end if + end if + + end subroutine add_hist_coord_regonly + + subroutine add_hist_coord_int(name, vlen, long_name, units, values, & + positive, standard_name, dimname) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in), optional :: units + integer, intent(in), target, optional :: values(:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + character(len=*), intent(in), optional :: dimname + + ! Local variables + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + i_values=values, positive=positive, standard_name=standard_name) + ! Register the name if necessary + if (i == 0) then + call add_hist_coord(trim(name), i) + if(masterproc) then + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + '(', i, ') with length: ', vlen + end if + end if + + ! Set the coord's values + hist_coords(i)%dimsize = vlen + if (len_trim(long_name) > max_chars) then + if(masterproc) then + write(iulog,*) 'WARNING: long_name for ',trim(name),' too long' + end if + end if + hist_coords(i)%long_name = trim(long_name) + if (present(units)) then + hist_coords(i)%units = trim(units) + else + hist_coords(i)%units = '' + end if + hist_coords(i)%integer_dim = .true. + if (present(values)) then + hist_coords(i)%integer_values => values + endif + if (present(positive)) then + hist_coords(i)%positive = trim(positive) + end if + if (present(standard_name)) then + hist_coords(i)%standard_name = trim(standard_name) + end if + hist_coords(i)%vertical_coord = .false. + if (present(dimname)) then + hist_coords(i)%dimname = trim(dimname) + else + hist_coords(i)%dimname = '' + end if + + end subroutine add_hist_coord_int + + subroutine add_hist_coord_r8(name, vlen, long_name, units, values, & + bounds_name, bounds, positive, standard_name, vertical_coord, dimname) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + real(r8), intent(in), target :: values(:) + character(len=*), intent(in), optional :: bounds_name + real(r8), intent(in), target, optional :: bounds(:,:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + logical, intent(in), optional :: vertical_coord + character(len=*), intent(in), optional :: dimname + + ! Local variables + character(len=120) :: errormsg + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + r_values=values, positive=positive, standard_name=standard_name, & + bounds_name=bounds_name, bounds=bounds) + ! Register the name if necessary + if (i == 0) then + call add_hist_coord(trim(name), i) + if(masterproc) then + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + '(', i, ') with length: ', vlen + end if + end if + + ! Set the coord's size + hist_coords(i)%dimsize = vlen + if (len_trim(long_name) > max_chars) then + if(masterproc) then + write(iulog,*) 'WARNING: long_name for ',trim(name),' too long' + end if + end if + hist_coords(i)%long_name = trim(long_name) + if (len_trim(units) > 0) then + hist_coords(i)%units = trim(units) + else + hist_coords(i)%units = '1' + end if + hist_coords(i)%integer_dim = .false. + hist_coords(i)%real_values => values + if (present(positive)) then + hist_coords(i)%positive = trim(positive) + end if + if (present(standard_name)) then + hist_coords(i)%standard_name = trim(standard_name) + end if + if (present(bounds_name)) then + hist_coords(i)%bounds_name = trim(bounds_name) + if (.not. present(bounds)) then + write(errormsg,*) 'bounds must be present for ',trim(bounds_name) + call endrun(errormsg) + end if + hist_coords(i)%bounds => bounds + else if (present(bounds)) then + write(errormsg,*) 'bounds_name must be present for bounds values' + call endrun(errormsg) + else + hist_coords(i)%bounds_name = '' + end if + if (present(vertical_coord)) then + hist_coords(i)%vertical_coord = vertical_coord + else + hist_coords(i)%vertical_coord = .false. + end if + if (present(dimname)) then + hist_coords(i)%dimname = trim(dimname) + else + hist_coords(i)%dimname = '' + end if + + end subroutine add_hist_coord_r8 + + subroutine add_vert_coord(name, vlen, long_name, units, values, & + positive, standard_name, formula_terms) + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + real(r8), intent(in), target :: values(:) + character(len=*), intent(in), optional :: positive + character(len=*), intent(in), optional :: standard_name + type(formula_terms_t), intent(in), optional :: formula_terms + + ! Local variable + integer :: i + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, & + r_values=values, positive=positive, standard_name=standard_name, & + formula_terms=formula_terms) + ! Register the name and hist_coord values if necessary + if (i == 0) then + call add_hist_coord(trim(name), vlen, long_name, units, values, & + positive=positive, standard_name=standard_name, & + vertical_coord=.true.) + i = get_hist_coord_index(trim(name)) + if(masterproc) then + write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), & + '(', i, ') with length: ', vlen + end if + end if + + if (present(formula_terms)) then + hist_coords(i)%formula_terms = formula_terms + end if + + end subroutine add_vert_coord + + subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid) + use pio, only: file_desc_t, var_desc_t, pio_put_att, pio_noerr, & + pio_int, pio_double, pio_inq_varid, pio_def_var + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: mdimind ! Internal dim index + integer, intent(in) :: boundsdim ! Bounds dimension ID + logical, intent(in) :: dimonly ! No def_var if .true. + integer, optional, intent(out) :: mdimid + + ! Local variables + integer :: dimid ! PIO dimension ID + type(var_desc_t) :: vardesc ! PIO variable descriptor + character(len=120) :: errormsg + character(len=max_chars) :: formula_terms ! Constructed string + integer :: ierr + integer :: dtype + logical :: defvar ! True if var exists + + ! Create or check dimension for this coordinate + if (len_trim(hist_coords(mdimind)%dimname) > 0) then + ! Dim can already exist if different from coord name + call cam_pio_def_dim(File, trim(hist_coords(mdimind)%dimname), & + hist_coords(mdimind)%dimsize, dimid, & + existOK=(trim(hist_coords(mdimind)%dimname) /= & + trim(hist_coords(mdimind)%name))) + else + ! The dimension has the same name as the coord -- must be new dim + call cam_pio_def_dim(File, trim(hist_coords(mdimind)%name), & + hist_coords(mdimind)%dimsize, dimid, existOK=.false.) + end if + ! If the caller wants to know the NetCDF dimension ID, set it here + if (present(mdimid)) then + mdimid = dimid + end if + if (.not. dimonly) then + ! Time to define the variable (only if there are values) + if (hist_coords(mdimind)%integer_dim) then + dtype = pio_int + defvar = associated(hist_coords(mdimind)%integer_values) + else + dtype = pio_double + defvar = associated(hist_coords(mdimind)%real_values) + end if + if (defvar) then + call cam_pio_def_var(File, trim(hist_coords(mdimind)%name), dtype, & + (/dimid/), vardesc, existOK=.false.) + ! long_name + ierr=pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_hist_coord_attr') + ! units + if(len_trim(hist_coords(mdimind)%units) > 0) then + ierr=pio_put_att(File, vardesc, 'units', & + trim(hist_coords(mdimind)%units)) + call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_hist_coord_attr') + end if + ! positive + if(len_trim(hist_coords(mdimind)%positive) > 0) then + ierr=pio_put_att(File, vardesc, 'positive', & + trim(hist_coords(mdimind)%positive)) + call cam_pio_handle_error(ierr, 'Error writing "positive" attr in write_hist_coord_attr') + end if + ! standard_name + if(len_trim(hist_coords(mdimind)%standard_name) > 0) then + ierr=pio_put_att(File, vardesc, 'standard_name', & + trim(hist_coords(mdimind)%standard_name)) + call cam_pio_handle_error(ierr, 'Error writing "standard_name" attr in write_hist_coord_attr') + end if + ! formula_terms + if(len_trim(hist_coords(mdimind)%formula_terms%a_name) > 0) then + write(formula_terms, '("a: ",a," b: ",a," p0: ",a," ps: ",a)') & + trim(hist_coords(mdimind)%formula_terms%a_name), & + trim(hist_coords(mdimind)%formula_terms%b_name), & + trim(hist_coords(mdimind)%formula_terms%p0_name),& + trim(hist_coords(mdimind)%formula_terms%ps_name) + ierr=pio_put_att(File, vardesc, 'formula_terms', trim(formula_terms)) + call cam_pio_handle_error(ierr, 'Error writing "formula_terms" attr in write_hist_coord_attr') + end if + ! bounds + if (associated(hist_coords(mdimind)%bounds)) then + ! Write name of the bounds variable + ierr=pio_put_att(File, vardesc, 'bounds', trim(hist_coords(mdimind)%bounds_name)) + call cam_pio_handle_error(ierr, 'Error writing "bounds" attr in write_hist_coord_attr') + end if + end if + + ! Now, we need to define and populate the associated bounds variable + ! NB: Reusing vardesc, no longer assocated with main variable + if (associated(hist_coords(mdimind)%bounds)) then + if (size(hist_coords(mdimind)%bounds,2) /= hist_coords(mdimind)%dimsize) then + ! If anyone hits this check, add a new dimension for this case + write(errormsg, *) 'The bounds variable, ', & + trim(hist_coords(mdimind)%bounds_name), & + ', needs to have dimension (2,', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%bounds_name), & + pio_double, (/boundsdim,dimid/), vardesc, existOK=.false.) + end if + + ! See if we have formula_terms variables to define + ! Define the "a" variable name + ! NB: Reusing vardesc, no longer assocated with previous variables + if (associated(hist_coords(mdimind)%formula_terms%a_values)) then + if (size(hist_coords(mdimind)%formula_terms%a_values) /= hist_coords(mdimind)%dimsize) then + write(errormsg, *) 'The forumla_terms variable, ', & + trim(hist_coords(mdimind)%formula_terms%a_name), & + ', needs to have dimension', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%a_name), & + pio_double, (/dimid/), vardesc, existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%a_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "a" formula_term in write_hist_coord_attr') + end if + ! Define the "b" variable name + ! NB: Reusing vardesc, no longer assocated with previous variables + if (associated(hist_coords(mdimind)%formula_terms%b_values)) then + if (size(hist_coords(mdimind)%formula_terms%b_values) /= hist_coords(mdimind)%dimsize) then + write(errormsg, *) 'The forumla_terms variable, ', & + trim(hist_coords(mdimind)%formula_terms%b_name), & + ', needs to have dimension', hist_coords(mdimind)%dimsize + call endrun(errormsg) + end if + call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%b_name), & + pio_double, (/dimid/), vardesc, existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%b_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "b" formula_term in write_hist_coord_attr') + end if + ! Maybe define the p0 variable (this may be defined already which is OK) + ! NB: Reusing vardesc, no longer assocated with previous variables + if (hist_coords(mdimind)%formula_terms%p0_value /= fillvalue) then + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%p0_name), vardesc) + if (ierr /= PIO_NOERR) then + ierr = pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%p0_name), & + pio_double, vardesc) + call cam_pio_handle_error(ierr, 'Unable to define "p0" formula_terms variable in write_hist_coord_attr') + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%p0_long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "p0" formula_term in write_hist_coord_attr') + ierr = pio_put_att(File, vardesc, 'units', trim(hist_coords(mdimind)%formula_terms%p0_units)) + call cam_pio_handle_error(ierr, 'Error writing "units" attr for "p0" formula_term in write_hist_coord_attr') + end if + end if + ! PS is not our responsibility + end if ! (.not. dimonly) + + end subroutine write_hist_coord_attr + + !--------------------------------------------------------------------------- + ! + ! write_hist_coord_attrs + ! + ! Write the dimension and coordinate attributes for the defined + ! history + ! coordinates. + ! + !--------------------------------------------------------------------------- + + subroutine write_hist_coord_attrs(File, boundsdim, mdimids, writemdims_in) + use pio, only: file_desc_t, var_desc_t, pio_put_att, & + pio_bcast_error, pio_internal_error, pio_seterrorhandling, & + pio_char + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: boundsdim ! Bounds dimension ID + integer, optional, allocatable, intent(out) :: mdimids(:) ! NetCDF dim IDs + logical, optional, intent(in) :: writemdims_in ! Write mdim variable + + ! Local variables + integer :: i + integer :: ierr + integer :: dimids(2) ! PIO dimension IDs + logical :: writemdims ! Define an mdim variable + type(var_desc_t) :: vardesc ! PIO variable descriptor + + if (present(mdimids)) then + allocate(mdimids(registeredmdims)) + end if + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR) + + if (present(writemdims_in)) then + writemdims = writemdims_in + else + writemdims = .false. + end if + + ! NB: Currently, writemdims is for restart and we don't need to write + ! these out in a history-restart file. This could change in the future. + ! which would require a change to the function of the fourth argument + ! Fill in the attribute information for each mdim + do i = 1, registeredmdims + if (present(mdimids)) then + call write_hist_coord_attr(File, i, boundsdim, writemdims, mdimids(i)) + else + call write_hist_coord_attr(File, i, boundsdim, writemdims) + end if + end do + + if (writemdims) then + call cam_pio_def_dim(File, 'mdimslen', max_hcoordname_len, dimids(1), & + existOK=.true.) + call cam_pio_def_dim(File, 'num_mdims', registeredmdims, dimids(2), & + existOK=.true.) + call cam_pio_def_var(File, mdim_var_name, pio_char, dimids, vardesc, & + existOK=.false.) + ierr = pio_put_att(File, vardesc, 'long_name', 'mdim dimension names') + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for mdimnames in write_hist_coord_attrs') + end if + + ! Back to I/O or die trying + call pio_seterrorhandling(File, PIO_INTERNAL_ERROR) + + end subroutine write_hist_coord_attrs + + !--------------------------------------------------------------------------- + + subroutine write_hist_coord_var(File, mdimind) + use pio, only: file_desc_t, var_desc_t, pio_put_var, pio_inq_varid + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: mdimind ! Internal dim index + + ! Local variables + type(var_desc_t) :: vardesc ! PIO variable descriptor + integer :: ierr + + if ((hist_coords(mdimind)%integer_dim .and. & + associated(hist_coords(mdimind)%integer_values)) .or. & + ((.not. hist_coords(mdimind)%integer_dim) .and. & + associated(hist_coords(mdimind)%real_values))) then + ! Check to make sure the variable already exists in the file + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent dimension variable write_hist_coord_var') + ! Write out the values for this dimension variable + if (hist_coords(mdimind)%integer_dim) then + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%integer_values) + else + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%real_values) + end if + call cam_pio_handle_error(ierr, 'Error writing variable values in write_hist_coord_var') + end if + + ! Now, we need to possibly write values for the associated bounds variable + if (associated(hist_coords(mdimind)%bounds)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%bounds_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent bounds variable write_hist_coord_var') + ! Write out the values for this bounds variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%bounds) + call cam_pio_handle_error(ierr, 'Error writing bounds values in write_hist_coord_var') + end if + + ! Write values for the "a" variable name + if (associated(hist_coords(mdimind)%formula_terms%a_values)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%a_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "a" formula_terms variable write_hist_coord_var') + ! Write out the values for this "a" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%a_values) + call cam_pio_handle_error(ierr, 'Error writing "a" formula_terms values in write_hist_coord_var') + end if + ! Write values for the "b" variable name + if (associated(hist_coords(mdimind)%formula_terms%b_values)) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%b_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "b" formula_terms variable write_hist_coord_var') + ! Write out the values for this "b" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%b_values) + call cam_pio_handle_error(ierr, 'Error writing "b" formula_terms values in write_hist_coord_var') + end if + ! Write values for the "p0" variable name (this may be an overwrite, too bad + if (hist_coords(mdimind)%formula_terms%p0_value /= fillvalue) then + ! Check to make sure the variable already exists in the file + ! NB: Reusing vardesc, no longer assocated with previous variables + ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%p0_name), vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "p0" formula_terms variable write_hist_coord_var') + ! Write out the values for this "p0" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%p0_value) + call cam_pio_handle_error(ierr, 'Error writing "p0" formula_terms values in write_hist_coord_var') + end if + + end subroutine write_hist_coord_var + + !--------------------------------------------------------------------------- + + subroutine write_hist_coord_vars(File, writemdims_in) + use pio, only: file_desc_t, var_desc_t, pio_put_var, & + pio_bcast_error, pio_internal_error, & + pio_seterrorhandling, pio_inq_varid + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + logical, optional, intent(in) :: writemdims_in ! Write mdim variable + + ! Local variables + integer :: i + integer :: ierr + logical :: writemdims ! Define an mdim variable + type(var_desc_t) :: vardesc ! PIO variable descriptor + character(len=max_hcoordname_len), allocatable :: mdimnames(:) + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR) + + if (present(writemdims_in)) then + writemdims = writemdims_in + else + writemdims = .false. + end if + + if (writemdims) then + allocate(mdimnames(registeredmdims)) + end if + + ! Write out the variable values for each mdim + do i = 1, registeredmdims + if (.not. writemdims) then + ! NB: Currently, writemdims is for restart and we don't need to write + ! these out in a history-restart file. This could change in the future + ! which is why it is a separate if block + ! Fill in the attribute information for each mdim + call write_hist_coord_var(File, i) + end if + if (writemdims) then + mdimnames(i) = trim(hist_coords(i)%name) + end if + end do + + if (writemdims) then + ierr = pio_inq_varid(File, mdim_var_name, vardesc) + call cam_pio_handle_error(ierr, 'Error writing values for nonexistent mdimnames variable in write_hist_coord_vars') + ! Write out the values for mdim names + ierr = pio_put_var(File, vardesc, mdimnames) + call cam_pio_handle_error(ierr, 'Error writing values for mdimnames variable in write_hist_coord_vars') + deallocate(mdimnames) + end if + + ! Back to I/O or die trying + call pio_seterrorhandling(File, PIO_INTERNAL_ERROR) + + end subroutine write_hist_coord_vars + + !--------------------------------------------------------------------------- + + subroutine lookup_hist_coord_indices(mdimnames, mdimindicies) + ! Dummy arguments + character(len=*), intent(in) :: mdimnames(:) + integer, intent(out) :: mdimindicies(:) + + ! Local variables + integer :: i, j + integer :: cnt + character(len=120) :: errormsg + character(len=16) :: name + + + cnt = size(mdimnames) + mdimindicies = -1 + + + do j=1,cnt + name = mdimnames(j) + do i = 1, registeredmdims + if(name .eq. hist_coords(i)%name) then + mdimindicies(j)=i + end if + end do + end do + do j = 1, cnt + if(mdimindicies(j) < 0) then + do i = 1, registeredmdims + print *,__FILE__,__LINE__,i,hist_coords(i)%name + end do + write(errormsg,*) 'Name ',mdimnames(j),' is not a registered history coordinate' + call endrun(errormsg) + end if + end do + + end subroutine lookup_hist_coord_indices + + !--------------------------------------------------------------------------- + ! Find the vertical dimension (if present) in dimnames and return its size + ! (which is the number of levels). Return -1 if not found + ! If dimnames is not present, search all of the registered history coords + integer function hist_coord_find_levels(dimnames) result(levels) + ! Dummy argument + character(len=*), optional, intent(in) :: dimnames(:) + + ! Local variables + integer i, index, dimcnt + + levels = -1 ! Error return value + + if (present(dimnames)) then + dimcnt = size(dimnames) + else + dimcnt = registeredmdims + end if + + do i = 1, dimcnt + if (present(dimnames)) then + index = get_hist_coord_index(trim(dimnames(i))) + if (i < 0) then + call endrun('hist_coord_find_levels: '//trim(dimnames(i))//' is not a registred history coordinate') + end if + else + index = i ! Just cycle through all the registered mdims + end if + + if (hist_coords(index)%vertical_coord) then + levels = hist_coords(index)%dimsize + exit + end if + end do + + end function hist_coord_find_levels + + end module cam_history_support diff --git a/src/utils/cam_filenames.F90 b/src/utils/cam_filenames.F90 index d1421c11..bcf19d1c 100644 --- a/src/utils/cam_filenames.F90 +++ b/src/utils/cam_filenames.F90 @@ -49,7 +49,7 @@ end function get_dir !=========================================================================== - character(len=cl) function interpret_filename_spec(filename_spec, unit, & + character(len=cl) function interpret_filename_spec(filename_spec, unit, accum_type, & prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec, incomplete_ok) ! Create a filename from a filename specifier. The @@ -61,6 +61,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & ! %c for case () ! %i for instance specification () ! %u for unit specification () + ! - accum_type, if present, is appended to ! %y for year () ! %m for month () ! %d for day () @@ -75,6 +76,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & ! Dummy Arguments character(len=*), intent(in) :: filename_spec character(len=*), optional, intent(in) :: unit + character(len=*), optional, intent(in) :: accum_type logical, optional, intent(in) :: prev character(len=*), optional, intent(in) :: case character(len=*), optional, intent(in) :: instance @@ -163,7 +165,11 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, & end if case('u') ! unit description (e.g., h2) if (present(unit)) then - string = trim(unit) + if (present(accum_type)) then + string = trim(unit) // trim(accum_type) + else + string = trim(unit) + end if else if (incomplete_ok_use) then string = "%u" else diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index 82d19671..32c7b8db 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -1,4347 +1,4337 @@ module cam_grid_support - use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4 - use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4 - use shr_kind_mod, only: max_chars=>shr_kind_cl - use shr_sys_mod, only: shr_sys_flush - use cam_map_utils, only: iMap - use pio, only: var_desc_t - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use spmd_utils, only: masterproc - use cam_pio_utils, only: cam_pio_handle_error - use cam_map_utils, only: cam_filemap_t - - implicit none - private - - integer, parameter, public :: max_hcoordname_len = 16 - real(r8), parameter :: grid_fill_value = -900.0_r8 - !--------------------------------------------------------------------------- - ! - ! horiz_coord_t: Information for horizontal dimension attributes - ! - !--------------------------------------------------------------------------- - type, public :: horiz_coord_t - private - character(len=max_hcoordname_len) :: name = '' ! coordinate name - character(len=max_hcoordname_len) :: dimname = '' ! dimension name - ! NB: If dimname is blank, it is assumed to be name - integer :: dimsize = 0 ! global size of dimension - character(len=max_chars) :: long_name = '' ! 'long_name' attribute - character(len=max_chars) :: units = '' ! 'units' attribute - real(r8), pointer :: values(:) => NULL() ! dim vals (local if map) - integer(iMap), pointer :: map(:) => NULL() ! map (dof) for dist. coord - logical :: latitude ! .false. means longitude - real(r8), pointer :: bnds(:,:) => NULL() ! bounds, if present - type(var_desc_t), pointer :: vardesc => NULL() ! If we are to write coord - type(var_desc_t), pointer :: bndsvdesc => NULL() ! Set to write bounds - contains - procedure :: get_coord_len => horiz_coord_len - procedure :: num_elem => horiz_coord_num_elem - procedure :: global_size => horiz_coord_find_size - procedure :: get_coord_name => horiz_coord_name - procedure :: get_dim_name => horiz_coord_dim_name - procedure :: get_long_name => horiz_coord_long_name - procedure :: get_units => horiz_coord_units - procedure :: write_attr => write_horiz_coord_attr - procedure :: write_var => write_horiz_coord_var - end type horiz_coord_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_t: Auxiliary quantity for a CAM grid - ! - !--------------------------------------------------------------------------- - type, abstract :: cam_grid_attribute_t - character(len=max_hcoordname_len) :: name = '' ! attribute name - character(len=max_chars) :: long_name = '' ! attr long_name - type(var_desc_t), pointer :: vardesc => NULL() - ! We aren't going to use this until we sort out PGI issues - class(cam_grid_attribute_t), pointer :: next => NULL() - contains - procedure :: cam_grid_attr_init - procedure(write_cam_grid_attr), deferred :: write_attr - procedure(write_cam_grid_attr), deferred :: write_val - procedure(print_attr_spec), deferred :: print_attr - procedure :: print_attr_base - end type cam_grid_attribute_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_0d_int_t: Global integral attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_int_t - integer :: ival - contains - procedure :: cam_grid_attr_init_0d_int - procedure :: write_attr => write_cam_grid_attr_0d_int - procedure :: write_val => write_cam_grid_val_0d_int - procedure :: print_attr => print_attr_0d_int - end type cam_grid_attribute_0d_int_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_0d_char_t: Global string attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_char_t - character(len=max_chars) :: val - contains - procedure :: cam_grid_attr_init_0d_char - procedure :: write_attr => write_cam_grid_attr_0d_char - procedure :: write_val => write_cam_grid_val_0d_char - procedure :: print_attr => print_attr_0d_char - end type cam_grid_attribute_0d_char_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_1d_int_t: 1-d integer attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_int_t - character(len=max_hcoordname_len) :: dimname ! attribute dimension - integer :: dimsize ! Global array/map size - integer, pointer :: values(:) => NULL() - integer(iMap), pointer :: map(:) => NULL() ! map (dof) 4 I/O - contains - procedure :: cam_grid_attr_init_1d_int - procedure :: write_attr => write_cam_grid_attr_1d_int - procedure :: write_val => write_cam_grid_val_1d_int - procedure :: print_attr => print_attr_1d_int - end type cam_grid_attribute_1d_int_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_1d_r8_t: 1-d real*8 attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_r8_t - character(len=max_hcoordname_len) :: dimname ! attribute dimension - integer :: dimsize ! Global array/map size - real(r8), pointer :: values(:) => NULL() - integer(iMap), pointer :: map(:) => NULL() ! map (dof) 4 I/O - contains - procedure :: cam_grid_attr_init_1d_r8 - procedure :: write_attr => write_cam_grid_attr_1d_r8 - procedure :: write_val => write_cam_grid_val_1d_r8 - procedure :: print_attr => print_attr_1d_r8 - end type cam_grid_attribute_1d_r8_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attr_ptr_t: linked list of CAM grid attributes - ! - !--------------------------------------------------------------------------- - type :: cam_grid_attr_ptr_t - private - class(cam_grid_attribute_t), pointer :: attr => NULL() - type(cam_grid_attr_ptr_t), pointer :: next => NULL() - contains - private - procedure, public :: initialize => initializeAttrPtr - procedure, public :: getAttr => getAttrPtrAttr - procedure, public :: getNext => getAttrPtrNext - procedure, public :: setNext => setAttrPtrNext - end type cam_grid_attr_ptr_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_t: Information for a CAM grid (defined by a dycore) - ! - !--------------------------------------------------------------------------- - type :: cam_grid_t - character(len=max_hcoordname_len) :: name = '' ! grid name - integer :: id ! e.g., dyn_decomp - type(horiz_coord_t), pointer :: lat_coord => NULL() ! Latitude - type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude - logical :: unstructured ! Is this needed? - logical :: block_indexed ! .false. for lon/lat - logical :: attrs_defined = .false. - logical :: zonal_grid = .false. - type(cam_filemap_t), pointer :: map => null() ! global dim map (dof) - type(cam_grid_attr_ptr_t), pointer :: attributes => NULL() - contains - procedure :: print_cam_grid - procedure :: is_unstructured => cam_grid_unstructured - procedure :: is_block_indexed => cam_grid_block_indexed - procedure :: is_zonal_grid => cam_grid_zonal_grid - procedure :: coord_lengths => cam_grid_get_dims - procedure :: coord_names => cam_grid_coord_names - procedure :: dim_names => cam_grid_dim_names - procedure :: num_elem => cam_grid_local_size - procedure :: set_map => cam_grid_set_map - procedure :: get_patch_mask => cam_grid_get_patch_mask - procedure :: get_lon_lat => cam_grid_get_lon_lat - procedure :: find_src_dims => cam_grid_find_src_dims - procedure :: find_dest_dims => cam_grid_find_dest_dims - procedure :: find_dimids => cam_grid_find_dimids - procedure :: get_decomp => cam_grid_get_pio_decomp - procedure :: read_darray_2d_int => cam_grid_read_darray_2d_int - procedure :: read_darray_3d_int => cam_grid_read_darray_3d_int - procedure :: read_darray_2d_double => cam_grid_read_darray_2d_double - procedure :: read_darray_3d_double => cam_grid_read_darray_3d_double - procedure :: read_darray_2d_real => cam_grid_read_darray_2d_real - procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real - procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int - procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int - procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double - procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double - procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real - procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real - end type cam_grid_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_patch_t: Information for a patch of a CAM grid - ! - !--------------------------------------------------------------------------- - type, public :: cam_grid_patch_t - private - integer :: grid_id = -1 ! grid with patch points - integer :: global_size = 0 ! var patch dim size - integer :: global_lat_size = 0 ! lat patch dim size - integer :: global_lon_size = 0 ! lon patch dim size - integer :: num_points = 0 ! task-local size - real(r8) :: lon_range(2) - real(r8) :: lat_range(2) - logical :: collected_columns ! Output unstructured - type(cam_filemap_t), pointer :: mask => null() ! map 4 active pts - integer(iMap), pointer :: latmap(:) => null() ! map 4 patch coords - integer(iMap), pointer :: lonmap(:) => null() ! map 4 patch coords - real(r8), pointer :: lonvals(:) => null() ! collected output - real(r8), pointer :: latvals(:) => null() ! collected output - contains - procedure :: gridid => cam_grid_patch_get_id - procedure :: get_axis_names => cam_grid_patch_get_axis_names - procedure :: get_coord_long_name => cam_grid_patch_get_coord_long_name - procedure :: get_coord_units => cam_grid_patch_get_coord_units - procedure :: set_patch => cam_grid_patch_set_patch - procedure :: get_decomp => cam_grid_patch_get_decomp - procedure :: compact => cam_grid_patch_compact - procedure :: active_cols => cam_grid_patch_get_active_cols - procedure :: write_coord_vals => cam_grid_patch_write_vals - procedure :: grid_index => cam_grid_patch_get_grid_index - procedure :: deallocate => cam_grid_patch_deallocate - !!XXgoldyXX: PGI workaround? - ! COMPILER_BUG(goldy, 2014-11-28, pgi <= 14.9); Commented code should work - ! procedure :: global_size_map => cam_grid_patch_get_global_size_map - ! procedure :: global_size_axes => cam_grid_patch_get_global_size_axes - ! generic :: get_global_size => global_size_map, global_size_axes - procedure :: cam_grid_patch_get_global_size_map - procedure :: cam_grid_patch_get_global_size_axes - generic :: get_global_size => cam_grid_patch_get_global_size_map, cam_grid_patch_get_global_size_axes - end type cam_grid_patch_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_header_info_t: Hold NetCDF dimension information for a CAM grid - ! - !--------------------------------------------------------------------------- - type, public :: cam_grid_header_info_t - private - integer :: grid_id = -1 ! e.g., dyn_decomp - integer, allocatable :: hdims(:) ! horizontal dimension ids - type(var_desc_t), pointer :: lon_varid => NULL() ! lon coord variable - type(var_desc_t), pointer :: lat_varid => NULL() ! lat coord variable - contains - procedure :: get_gridid => cam_grid_header_info_get_gridid - procedure :: set_gridid => cam_grid_header_info_set_gridid - procedure :: set_hdims => cam_grid_header_info_set_hdims - procedure :: num_hdims => cam_grid_header_info_num_hdims - procedure :: get_hdimid => cam_grid_header_info_hdim - !!XXgoldyXX: Maybe replace this with horiz_coords for patches? - procedure :: set_varids => cam_grid_header_info_set_varids - procedure :: get_lon_varid => cam_grid_header_info_lon_varid - procedure :: get_lat_varid => cam_grid_header_info_lat_varid - procedure :: deallocate => cam_grid_header_info_deallocate - end type cam_grid_header_info_t - - !--------------------------------------------------------------------------- - ! - ! END: types BEGIN: interfaces for types - ! - !--------------------------------------------------------------------------- - - ! Abstract interface for write_attr procedure of cam_grid_attribute_t class - abstract interface - subroutine write_cam_grid_attr(attr, File) - use pio, only: file_desc_t - import :: cam_grid_attribute_t - ! Dummy arguments - class(cam_grid_attribute_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - end subroutine write_cam_grid_attr - end interface - - ! Abstract interface for print_attr procedure of cam_grid_attribute_t class - abstract interface - subroutine print_attr_spec(this) - import :: cam_grid_attribute_t - ! Dummy arguments - class(cam_grid_attribute_t), intent(in) :: this - end subroutine print_attr_spec - end interface - - !! Grid variables - integer, parameter :: maxhgrids = 16 ! arbitrary limit - integer, save :: registeredhgrids = 0 - type(cam_grid_t), save :: cam_grids(maxhgrids) - - public :: horiz_coord_create - - ! Setup and I/O functions for grids rely on the grid's ID, not its index. - public :: cam_grid_register, cam_grid_attribute_register - public :: cam_grid_attribute_copy - public :: cam_grid_write_attr, cam_grid_write_var - public :: cam_grid_read_dist_array, cam_grid_write_dist_array - ! Access functions for grids rely on the grid's ID or name, not its index. - public :: cam_grid_dimensions, cam_grid_num_grids - public :: cam_grid_check ! T/F if grid ID exists - public :: cam_grid_id ! Grid ID (decomp) or -1 if error - public :: cam_grid_get_local_size - public :: cam_grid_get_file_dimids - public :: cam_grid_get_decomp - public :: cam_grid_get_gcid - public :: cam_grid_get_array_bounds - public :: cam_grid_get_coord_names, cam_grid_get_dim_names - public :: cam_grid_has_blocksize, cam_grid_get_block_count - public :: cam_grid_get_latvals, cam_grid_get_lonvals - public :: cam_grid_get_coords - public :: cam_grid_is_unstructured, cam_grid_is_block_indexed - public :: cam_grid_attr_exists - public :: cam_grid_is_zonal - ! Functions for dealing with patch masks - public :: cam_grid_compute_patch - - interface cam_grid_attribute_register - module procedure add_cam_grid_attribute_0d_int - module procedure add_cam_grid_attribute_0d_char - module procedure add_cam_grid_attribute_1d_int - module procedure add_cam_grid_attribute_1d_r8 - end interface cam_grid_attribute_register - - interface cam_grid_dimensions - module procedure cam_grid_dimensions_id - module procedure cam_grid_dimensions_name - end interface cam_grid_dimensions - - interface cam_grid_get_dim_names - module procedure cam_grid_get_dim_names_id - module procedure cam_grid_get_dim_names_name - end interface cam_grid_get_dim_names - - interface cam_grid_read_dist_array - module procedure cam_grid_read_dist_array_2d_int - module procedure cam_grid_read_dist_array_3d_int - module procedure cam_grid_read_dist_array_2d_double - module procedure cam_grid_read_dist_array_3d_double - module procedure cam_grid_read_dist_array_2d_real - module procedure cam_grid_read_dist_array_3d_real - end interface cam_grid_read_dist_array - - interface cam_grid_write_dist_array - module procedure cam_grid_write_dist_array_2d_int - module procedure cam_grid_write_dist_array_3d_int - module procedure cam_grid_write_dist_array_2d_double - module procedure cam_grid_write_dist_array_3d_double - module procedure cam_grid_write_dist_array_2d_real - module procedure cam_grid_write_dist_array_3d_real - end interface cam_grid_write_dist_array - - ! Private interfaces - interface get_cam_grid_index - module procedure get_cam_grid_index_char ! For lookup by name - module procedure get_cam_grid_index_int ! For lookup by ID - end interface get_cam_grid_index - -contains - - !!####################################################################### - !! - !! Horizontal coordinate functions - !! - !!####################################################################### - - integer function horiz_coord_find_size(this, dimname) result(dimsize) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(in) :: dimname - - dimsize = -1 - if (len_trim(this%dimname) == 0) then - if(trim(dimname) == trim(this%name)) then - dimsize = this%dimsize - end if - else - if(trim(dimname) == trim(this%dimname)) then - dimsize = this%dimsize - end if - end if - - end function horiz_coord_find_size - - integer function horiz_coord_num_elem(this) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - - if (associated(this%values)) then - horiz_coord_num_elem = size(this%values) - else - horiz_coord_num_elem = 0 - end if - - end function horiz_coord_num_elem - - subroutine horiz_coord_len(this, clen) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - integer, intent(out) :: clen - - clen = this%dimsize - end subroutine horiz_coord_len - - subroutine horiz_coord_name(this, name) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: name - - if (len(name) < len_trim(this%name)) then - call endrun('horiz_coord_name: input name too short') - end if - name = trim(this%name) - end subroutine horiz_coord_name - - subroutine horiz_coord_dim_name(this, dimname) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: dimname - - if (len_trim(this%dimname) > 0) then - ! We have a separate dimension name (e.g., ncol) - if (len(dimname) < len_trim(this%dimname)) then - call endrun('horiz_coord_dimname: input name too short') - end if - dimname = trim(this%dimname) - else - ! No dimension name so we use the coordinate's name - ! i.e., The dimension name is the same as the coordinate variable - if (len(dimname) < len_trim(this%name)) then - call endrun('horiz_coord_dimname: input name too short') - end if - dimname = trim(this%name) - end if - end subroutine horiz_coord_dim_name - - subroutine horiz_coord_long_name(this, name) - - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: name - - if (len(name) < len_trim(this%long_name)) then - call endrun('horiz_coord_long_name: input name too short') - else - name = trim(this%long_name) - end if - - end subroutine horiz_coord_long_name - - subroutine horiz_coord_units(this, units) - - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: units - - if (len(units) < len_trim(this%units)) then - call endrun('horiz_coord_units: input units too short') - else - units = trim(this%units) - end if - - end subroutine horiz_coord_units - - function horiz_coord_create(name, dimname, dimsize, long_name, units, & - lbound, ubound, values, map, bnds) result(newcoord) - - ! Dummy arguments - character(len=*), intent(in) :: name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: units - ! NB: Sure, pointers would have made sense but . . . PGI - integer, intent(in) :: lbound - integer, intent(in) :: ubound - real(r8), intent(in) :: values(lbound:ubound) - integer(iMap), intent(in), optional :: map(ubound-lbound+1) - real(r8), intent(in), optional :: bnds(2,lbound:ubound) - type(horiz_coord_t), pointer :: newcoord - - allocate(newcoord) - - newcoord%name = trim(name) - newcoord%dimname = trim(dimname) - newcoord%dimsize = dimsize - newcoord%long_name = trim(long_name) - newcoord%units = trim(units) - ! Figure out if this is a latitude or a longitude using CF standard - ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#latitude-coordinate - ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#longitude-coordinate - if ( (trim(units) == 'degrees_north') .or. & - (trim(units) == 'degree_north') .or. & - (trim(units) == 'degree_N') .or. & - (trim(units) == 'degrees_N') .or. & - (trim(units) == 'degreeN') .or. & - (trim(units) == 'degreesN')) then - newcoord%latitude = .true. - else if ((trim(units) == 'degrees_east') .or. & - (trim(units) == 'degree_east') .or. & - (trim(units) == 'degree_E') .or. & - (trim(units) == 'degrees_E') .or. & - (trim(units) == 'degreeE') .or. & - (trim(units) == 'degreesE')) then - newcoord%latitude = .false. - else - call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'") - end if - allocate(newcoord%values(lbound:ubound)) - if (ubound >= lbound) then - newcoord%values(:) = values(:) - end if - - if (present(map)) then - if (ANY(map < 0)) then - call endrun("horiz_coord_create "//trim(name)//": map vals < 0") - end if - allocate(newcoord%map(ubound - lbound + 1)) - if (ubound >= lbound) then - newcoord%map(:) = map(:) - end if - else - nullify(newcoord%map) - end if - - if (present(bnds)) then - allocate(newcoord%bnds(2, lbound:ubound)) - if (ubound >= lbound) then - newcoord%bnds = bnds - end if - else - nullify(newcoord%bnds) - end if - - end function horiz_coord_create - - !------------------------------------------------------------------------ - ! - ! write_horiz_coord_attr - ! - ! Write the dimension and coordinate attributes for a horizontal grid - ! coordinate. - ! - !------------------------------------------------------------------------ - - subroutine write_horiz_coord_attr(this, File, dimid_out) - use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double - use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid - use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var - - ! Dummy arguments - class(horiz_coord_t), intent(inout) :: this - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(out) :: dimid_out - - ! Local variables - type(var_desc_t) :: vardesc - character(len=max_hcoordname_len) :: dimname - integer :: dimid ! PIO dimension ID - integer :: bnds_dimid ! PIO dim for bounds - integer :: err_handling - integer :: ierr - - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) - - ! Make sure the dimension exists in the file - call this%get_dim_name(dimname) - call cam_pio_def_dim(File, trim(dimname), this%dimsize, dimid, & - existOK=.true.) - ! Should we define the variable? - ierr = pio_inq_varid(File, trim(this%name), vardesc) - if (ierr /= PIO_NOERR) then - ! Variable not already defined, we need to define the variable - if (associated(this%vardesc)) then - ! This should not happen (i.e., internal error) - call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname)) - end if - allocate(this%vardesc) - call cam_pio_def_var(File, trim(this%name), pio_double, & - (/ dimid /), this%vardesc, existOK=.false.) - ierr= pio_put_att(File, this%vardesc, '_FillValue', grid_fill_value) - call cam_pio_handle_error(ierr, & - 'Error writing "_FillValue" attr in write_horiz_coord_attr') - ! long_name - ierr=pio_put_att(File, this%vardesc, 'long_name', & - trim(this%long_name)) - call cam_pio_handle_error(ierr, & - 'Error writing "long_name" attr in write_horiz_coord_attr') - ! units - ierr=pio_put_att(File, this%vardesc, 'units', trim(this%units)) - call cam_pio_handle_error(ierr, & - 'Error writing "units" attr in write_horiz_coord_attr') - ! Take care of bounds if they exist - if (associated(this%bnds)) then - allocate(this%bndsvdesc) - ierr = pio_put_att(File, this%vardesc, 'bounds', & - trim(this%name)//'_bnds') - call cam_pio_handle_error(ierr, & - 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr') - call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.) - call cam_pio_def_var(File, & - trim(this%name)//'_bnds', pio_double, & - (/ bnds_dimid, dimid /), this%bndsvdesc, existOK=.false.) - call cam_pio_handle_error(ierr, & - 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr') - ! long_name - ierr = pio_put_att(File, this%bndsvdesc, 'long_name', & - trim(this%name)//' bounds') - call cam_pio_handle_error(ierr, & - 'Error writing bounds "long_name" attr in write_horiz_coord_attr') - ! fill value - ierr = pio_put_att(File, this%vardesc, '_FillValue', & - grid_fill_value) - call cam_pio_handle_error(ierr, & - 'Error writing "_FillValue" attr in write_horiz_coord_attr') - ! units - ierr = pio_put_att(File, this%bndsvdesc, 'units', & - trim(this%units)) - call cam_pio_handle_error(ierr, & - 'Error writing bounds "units" attr in write_horiz_coord_attr') - end if ! There are bounds for this coordinate - end if ! We define the variable - - if (present(dimid_out)) then - dimid_out = dimid - end if - - ! Back to old error handling - call pio_seterrorhandling(File, err_handling) - - end subroutine write_horiz_coord_attr - - !------------------------------------------------------------------------ - ! - ! write_horiz_coord_var - ! - ! Write the coordinate values for this coordinate - ! - !------------------------------------------------------------------------ - - subroutine write_horiz_coord_var(this, File) - use cam_pio_utils, only: cam_pio_get_decomp, cam_pio_newdecomp - use pio, only: file_desc_t, pio_double - use pio, only: pio_put_var, pio_write_darray - use pio, only: pio_bcast_error, pio_seterrorhandling - !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! - !!XXgoldyXX: The issue is cam_pio_utils depending on stuff in this module - use pio, only: io_desc_t, pio_freedecomp, pio_syncfile - !!XXgoldyXX: End of this part of the hack - - ! Dummy arguments - class(horiz_coord_t), intent(inout) :: this - type(file_desc_t), intent(inout) :: File ! PIO file Handle - - ! Local variables - character(len=120) :: errormsg - integer :: ierr - integer :: ldims(1) - integer :: fdims(1) - integer :: err_handling - type(io_desc_t), pointer :: iodesc - - nullify(iodesc) - ! Check to make sure we are supposed to write this var - if (associated(this%vardesc)) then - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR, & - oldmethod=err_handling) - - ! Write out the values for this dimension variable - if (associated(this%map)) then - ! This is a distributed variable, use pio_write_darray -#if 0 - ldims(1) = this%num_elem() - call this%get_coord_len(fdims(1)) - allocate(iodesc) - call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, this%vardesc, iodesc, this%values, ierr) - nullify(iodesc) ! CAM PIO system takes over memory management of iodesc -#else - !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! - call cam_pio_newdecomp(iodesc, (/this%dimsize/), this%map, pio_double) - call pio_write_darray(File, this%vardesc, iodesc, this%values, ierr) - - call pio_syncfile(File) - call pio_freedecomp(File, iodesc) - ! Take care of bounds if they exist - if (associated(this%bnds) .and. associated(this%bndsvdesc)) then - call cam_pio_newdecomp(iodesc, (/2, this%dimsize/), & - this%map, pio_double) - call pio_write_darray(File, this%bndsvdesc, iodesc, & - this%bnds, ierr) - call pio_syncfile(File) - call pio_freedecomp(File, iodesc) - end if -#endif - !!XXgoldyXX: End of this part of the hack - else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, this%vardesc, this%values) - ! Take care of bounds if they exist - if (associated(this%bnds) .and. associated(this%bndsvdesc)) then - ierr = pio_put_var(File, this%bndsvdesc, this%bnds) - end if - end if - write(errormsg, *) 'Error writing variable values for ', & - trim(this%name), ' in write_horiz_coord_var' - call cam_pio_handle_error(ierr, errormsg) - - ! Back to old error handling - call pio_seterrorhandling(File, err_handling) - - ! We are done with this variable descriptor, reset for next file - deallocate(this%vardesc) - nullify(this%vardesc) - ! Same with the bounds descriptor - if (associated(this%bndsvdesc)) then - deallocate(this%bndsvdesc) - nullify(this%bndsvdesc) - end if - end if ! Do we write the variable? - - end subroutine write_horiz_coord_var - - !!####################################################################### - !! - !! CAM grid functions - !! - !!####################################################################### - - integer function get_cam_grid_index_char(gridname) - ! Dummy arguments - character(len=*), intent(in) :: gridname - ! Local variables - integer :: i - - get_cam_grid_index_char = -1 - do i = 1, registeredhgrids - if(trim(gridname) == trim(cam_grids(i)%name)) then - get_cam_grid_index_char = i - exit - end if - end do - - end function get_cam_grid_index_char - - integer function get_cam_grid_index_int(gridid) - ! Dummy arguments - integer, intent(in) :: gridid - ! Local variables - integer :: i - - get_cam_grid_index_int = -1 - do i = 1, registeredhgrids - if(gridid == cam_grids(i)%id) then - get_cam_grid_index_int = i - exit - end if - end do - - end function get_cam_grid_index_int - - subroutine find_cam_grid_attr(gridind, name, attr) - ! Dummy arguments - integer, intent(in) :: gridind - character(len=*), intent(in) :: name - class(cam_grid_attribute_t), pointer, intent(out) :: attr - ! Local variable - type(cam_grid_attr_ptr_t), pointer :: attrPtr - - nullify(attr) - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) - !!XXgoldyXX: Is this not working in PGI? - ! attr => attrPtr%getAttr() - attr => attrPtr%attr - if (trim(name) == trim(attr%name)) then - exit - else - !!XXgoldyXX: Is this not working in PGI? - ! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - nullify(attr) - end if - end do - return ! attr should be NULL if not found - end subroutine find_cam_grid_attr - - logical function cam_grid_attr_exists(gridname, name) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - ! Local variables - class(cam_grid_attribute_t), pointer :: attr - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, name, attr) - cam_grid_attr_exists = associated(attr) - nullify(attr) - else - call endrun('cam_grid_attr_exists: Bad grid name, "'//trim(gridname)//'"') - end if - end function cam_grid_attr_exists - - integer function num_cam_grid_attrs(gridind) - ! Dummy arguments - integer, intent(in) :: gridind - - ! Local variables - class(cam_grid_attr_ptr_t), pointer :: attrPtr - - num_cam_grid_attrs = 0 - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) - num_cam_grid_attrs = num_cam_grid_attrs + 1 - !!XXgoldyXX: Is this not working in PGI? - ! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - end function num_cam_grid_attrs - - subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & - unstruct, block_indexed, zonal_grid, src_in, dest_in) - ! Dummy arguments - character(len=*), intent(in) :: name - integer, intent(in) :: id - type(horiz_coord_t), pointer, intent(in) :: lat_coord - type(horiz_coord_t), pointer, intent(in) :: lon_coord - integer(iMap), pointer, intent(in) :: map(:,:) - logical, optional, intent(in) :: unstruct - logical, optional, intent(in) :: block_indexed - logical, optional, intent(in) :: zonal_grid - integer, optional, intent(in) :: src_in(2) - integer, optional, intent(in) :: dest_in(2) - - ! Local variables - character(len=max_hcoordname_len) :: latdimname, londimname - character(len=120) :: errormsg - integer :: i - integer :: src(2), dest(2) - character(len=*), parameter :: subname = 'CAM_GRID_REGISTER' - - ! For a values grid, we do not allow multiple calls - if (get_cam_grid_index(trim(name)) > 0) then - call endrun(trim(subname)//': Grid, '//trim(name)//', already exists') - else if (get_cam_grid_index(id) > 0) then - i = get_cam_grid_index(id) - write(errormsg, '(4a,i5,3a)') trim(subname), & - ': Attempt to add grid, ', trim(name), ' with id = ', id, & - ', however, grid ', trim(cam_grids(i)%name), & - ' already has that ID' - call endrun(trim(errormsg)) - else if (registeredhgrids >= maxhgrids) then - call endrun(trim(subname)//": Too many grids") - else - registeredhgrids = registeredhgrids + 1 - cam_grids(registeredhgrids)%name = trim(name) - cam_grids(registeredhgrids)%id = id - ! Quick sanity checks to make sure these aren't mixed up - if (.not. lat_coord%latitude) then - call endrun(subname//': lat_coord is not a latitude coordinate') - end if - if (lon_coord%latitude) then - call endrun(subname//': lon_coord is not a longitude coordinate') - end if - cam_grids(registeredhgrids)%lat_coord => lat_coord - cam_grids(registeredhgrids)%lon_coord => lon_coord - call lat_coord%get_dim_name(latdimname) - call lon_coord%get_dim_name(londimname) - if (present(unstruct)) then - cam_grids(registeredhgrids)%unstructured = unstruct - else - if (trim(latdimname) == trim(londimname)) then - cam_grids(registeredhgrids)%unstructured = .true. - else - cam_grids(registeredhgrids)%unstructured = .false. - end if - end if - if (present(block_indexed)) then - cam_grids(registeredhgrids)%block_indexed = block_indexed - else - cam_grids(registeredhgrids)%block_indexed = cam_grids(registeredhgrids)%unstructured - end if - if (present(zonal_grid)) then - ! Check the size of the longitude coordinate - call lon_coord%get_coord_len(i) - if (i /= 1) then - call endrun(subname//': lon_coord is not of size 1 for a zonal grid') - end if - cam_grids(registeredhgrids)%zonal_grid = zonal_grid - else - cam_grids(registeredhgrids)%zonal_grid = .false. - end if - if (associated(cam_grids(registeredhgrids)%map)) then - call endrun(trim(subname)//": new grid map should not be associated") - end if - if (present(src_in)) then - src = src_in - else - src(1) = 1 - src(2) = -1 - end if - if (present(dest_in)) then - dest = dest_in - else - dest(1) = 1 - if (cam_grids(registeredhgrids)%unstructured) then - dest(2) = 0 - else - dest(2) = 2 - end if - end if - allocate(cam_grids(registeredhgrids)%map) - call cam_grids(registeredhgrids)%map%init(map, & - cam_grids(registeredhgrids)%unstructured, src, dest) - call cam_grids(registeredhgrids)%print_cam_grid() - end if - - end subroutine cam_grid_register - - subroutine print_cam_grid(this) - class(cam_grid_t) :: this - - type(cam_grid_attr_ptr_t), pointer :: attrPtr - class(cam_grid_attribute_t), pointer :: attr - if (masterproc) then - write(iulog, '(3a,i4,4a,3(a,l2))') 'Grid: ', trim(this%name), & - ', ID = ', this%id, & - ', lat coord = ', trim(this%lat_coord%name), & - ', lon coord = ', trim(this%lon_coord%name), & - ', unstruct = ', this%unstructured, & - ', block_ind = ', this%block_indexed, & - ', zonal_grid = ', this%zonal_grid - attrPtr => this%attributes - do while (associated(attrPtr)) - !!XXgoldyXX: Is this not working in PGI? - ! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%print_attr() - !!XXgoldyXX: Is this not working in PGI? - ! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - end if - end subroutine print_cam_grid - - integer function cam_grid_num_grids() - cam_grid_num_grids = registeredhgrids - end function cam_grid_num_grids - - ! Return .true. iff id represents a valid CAM grid - logical function cam_grid_check(id) - ! Dummy argument - integer, intent(in) :: id - - cam_grid_check = ((get_cam_grid_index(id) > 0) .and. & - (get_cam_grid_index(id) <= cam_grid_num_grids())) - end function cam_grid_check - - integer function cam_grid_id(name) - ! Dummy argument - character(len=*), intent(in) :: name - - ! Local variable - integer :: index - - index = get_cam_grid_index(name) - if (index > 0) then - cam_grid_id = cam_grids(index)%id - else - cam_grid_id = -1 - end if - - end function cam_grid_id - - ! Return the size of a local array for grid, ID. - ! With no optional argument, return the basic 2D array size - ! nlev represents levels or the total column size (product(mdims)) - integer function cam_grid_get_local_size(id, nlev) - - ! Dummy arguments - integer, intent(in) :: id - integer, optional, intent(in) :: nlev - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - cam_grid_get_local_size = cam_grids(gridid)%num_elem() - if (present(nlev)) then - cam_grid_get_local_size = cam_grid_get_local_size * nlev - end if - else - write(errormsg, *) 'cam_grid_get_local_size: Bad grid ID, ', id - call endrun(errormsg) - end if - - end function cam_grid_get_local_size - - ! Given some array information, find the dimension NetCDF IDs on - ! for this grid - subroutine cam_grid_get_file_dimids(id, File, dimids) - use pio, only: file_desc_t - - ! Dummy arguments - integer, intent(in) :: id - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(out) :: dimids(:) - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%find_dimids(File, dimids) - else - write(errormsg, *) 'cam_grid_get_file_dimids: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_get_file_dimids - - ! Given some array information, find or compute a PIO decomposition - subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, & - iodesc, field_dnames, file_dnames) - use pio, only: io_desc_t - - ! Dummy arguments - integer, intent(in) :: id - ! field_lens: Array dim sizes - integer, intent(in) :: field_lens(:) - ! file_lens: File dim sizes - integer, intent(in) :: file_lens(:) - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - character(len=*), optional, intent(in) :: field_dnames(:) - character(len=*), optional, intent(in) :: file_dnames(:) - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%get_decomp(field_lens, file_lens, dtype, & - iodesc, field_dnames, file_dnames) - else - write(errormsg, *) 'cam_grid_get_decomp: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_get_decomp - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_2d_int - ! - ! Interface function for the grid%read_darray_2d_int method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_int(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_2d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_3d_int - ! - ! Interface function for the grid%read_darray_2d_ method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_int(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_3d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_2d_double - ! - ! Interface function for the grid%read_darray_2d_double method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_double(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_2d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_3d_double - ! - ! Interface function for the grid%read_darray_3d_double method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_double(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_3d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_2d_real - ! - ! Interface function for the grid%read_darray_2d_real method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_real(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_2d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_dist_array_3d_real - ! - ! Interface function for the grid%read_darray_3d_real method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_real(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_read_dist_array_3d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_2d_int - ! - ! Interface function for the grid%write_darray_2d_int method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_int(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_2d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_3d_int - ! - ! Interface function for the grid%write_darray_3d_int method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_int(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_3d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_2d_double - ! - ! Interface function for the grid%write_darray_2d_double method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_double(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_2d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_3d_double - ! - ! Interface function for the grid%write_darray_3d_double method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_double(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_3d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_2d_real - ! - ! Interface function for the grid%write_darray_2d_real method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_real(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_2d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_dist_array_3d_real - ! - ! Interface function for the grid%write_darray_3d_real method - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_real(File, adims, fdims, & - hbuf, varid) - else - write(errormsg, *) & - 'cam_grid_write_dist_array_3d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_gcid - ! - ! Find the global column ID for every local column - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_gcid(id, gcid) - - ! Dummy arguments - integer, intent(in) :: id - integer(iMap), pointer :: gcid(:) - - ! Local variables - integer :: gridid - integer :: fieldbounds(2,2) - integer :: fieldlens(2) - integer :: filelens(2) - type(cam_filemap_t), pointer :: map - - gridid = get_cam_grid_index(id) - if ((gridid > 0) .and. (gridid <= cam_grid_num_grids())) then - map => cam_grids(gridid)%map - call cam_grids(gridid)%coord_lengths(filelens) - call map%array_bounds(fieldbounds) - fieldlens(:) = fieldbounds(:,2) - fieldbounds(:,1) + 1 - call map%get_filemap(fieldlens, filelens, gcid) - else - call endrun('cam_grid_get_gcid: Bad grid ID') - end if - end subroutine cam_grid_get_gcid - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_array_bounds: Return grid bounds for the relevant array - ! Only modifies the dimensions corresponding to the map's src - ! dims should be sized (rank,2) with the second dimension used - ! to store lower(1) and upper(2) bounds - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_array_bounds(id, dims) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(inout) :: dims(:,:) - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_get_array_bounds: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - call cam_grids(gridid)%map%array_bounds(dims) - end if - else - call endrun('cam_grid_get_array_bounds: Bad grid ID') - end if - - end subroutine cam_grid_get_array_bounds - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_coord_names: Return the names of the grid axes - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_coord_names(id, lon_name, lat_name) - - ! Dummy arguments - integer, intent(in) :: id - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: lat_name - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%coord_names(lon_name, lat_name) - else - call endrun('cam_grid_get_coord_names: Bad grid ID') - end if - - end subroutine cam_grid_get_coord_names - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_dim_names: Return the names of the grid axes dimensions. - ! Note that these may be the same - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_dim_names_id(id, name1, name2) - - ! Dummy arguments - integer, intent(in) :: id - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%dim_names(name1, name2) - else - call endrun('cam_grid_get_dim_names_id: Bad grid ID') - end if - - end subroutine cam_grid_get_dim_names_id - - subroutine cam_grid_get_dim_names_name(gridname, name1, name2) - - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - ! Local variables - integer :: gridind - character(len=120) :: errormsg - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind < 0) then - write(errormsg, *) 'No CAM grid with name = ', trim(gridname) - call endrun('cam_grid_get_dim_names_name: '//errormsg) - else - call cam_grids(gridind)%dim_names(name1, name2) - end if - - end subroutine cam_grid_get_dim_names_name - - logical function cam_grid_has_blocksize(id) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_has_blocksize: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - cam_grid_has_blocksize = cam_grids(gridid)%map%has_blocksize() - end if - else - call endrun('cam_grid_has_blocksize: Bad grid ID') - end if - end function cam_grid_has_blocksize - - ! Return the number of active columns in the block specified by block_id - integer function cam_grid_get_block_count(id, block_id) result(ncol) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(in) :: block_id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_get_block_count: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - ncol = cam_grids(gridid)%map%blocksize(block_id) - end if - else - call endrun('cam_grid_get_block_count: Bad grid ID') - end if - end function cam_grid_get_block_count - - function cam_grid_get_latvals(id) result(latvals) - - ! Dummy argument - integer, intent(in) :: id - real(r8), pointer :: latvals(:) - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%lat_coord%values)) then - nullify(latvals) - else - latvals => cam_grids(gridid)%lat_coord%values - end if - else - call endrun('cam_grid_get_latvals: Bad grid ID') - end if - end function cam_grid_get_latvals - - function cam_grid_get_lonvals(id) result(lonvals) - - ! Dummy arguments - integer, intent(in) :: id - real(r8), pointer :: lonvals(:) - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%lon_coord%values)) then - nullify(lonvals) - else - lonvals => cam_grids(gridid)%lon_coord%values - end if - else - call endrun('cam_grid_get_lonvals: Bad grid ID') - end if - end function cam_grid_get_lonvals - - ! Find the longitude and latitude of a range of map entries - ! beg and end are the range of the first source index. blk is a block or chunk index - subroutine cam_grid_get_coords(id, beg, end, blk, lon, lat) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(in) :: beg - integer, intent(in) :: end - integer, intent(in) :: blk - real(r8), intent(inout) :: lon(:) - real(r8), intent(inout) :: lat(:) - - ! Local variables - integer :: gridid - integer :: i - gridid = get_cam_grid_index(id) - if (gridid > 0) then - do i = beg, end - if (cam_grids(gridid)%is_unstructured()) then - call endrun('cam_grid_get_coords: Not implemented') - else - call endrun('cam_grid_get_coords: Not implemented') - end if - end do - else - call endrun('cam_grid_get_coords: Bad grid ID') - end if - end subroutine cam_grid_get_coords - - logical function cam_grid_is_unstructured(id) result(unstruct) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - unstruct = cam_grids(gridid)%is_unstructured() - else - call endrun('cam_grid_is_unstructured: Bad grid ID') - end if - end function cam_grid_is_unstructured - - logical function cam_grid_is_block_indexed(id) result(block_indexed) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - block_indexed = cam_grids(gridid)%is_block_indexed() - else - call endrun('s: Bad grid ID') - end if - end function cam_grid_is_block_indexed - - logical function cam_grid_is_zonal(id) result(zonal) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - zonal = cam_grids(gridid)%is_zonal_grid() - else - call endrun('s: Bad grid ID') - end if - end function cam_grid_is_zonal - - ! Compute or update a grid patch mask - subroutine cam_grid_compute_patch(id, patch, lonl, lonu, latl, latu, cco) - - ! Dummy arguments - integer, intent(in) :: id - type(cam_grid_patch_t), intent(inout) :: patch - real(r8), intent(in) :: lonl - real(r8), intent(in) :: lonu - real(r8), intent(in) :: latl - real(r8), intent(in) :: latu - logical, intent(in) :: cco ! Collect cols? - - ! Local variables - integer :: gridid - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%get_patch_mask(lonl, lonu, latl, latu, patch, cco) - else - call endrun('cam_grid_compute_patch: Bad grid ID') - end if - - end subroutine cam_grid_compute_patch - - !!####################################################################### - !! - !! CAM grid attribute functions - !! - !!####################################################################### - - subroutine cam_grid_attr_init(this, name, long_name, next) - ! Dummy arguments - class(cam_grid_attribute_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - class(cam_grid_attribute_t), pointer :: next - - this%name = trim(name) - this%long_name = trim(long_name) - this%next => next - end subroutine cam_grid_attr_init - - subroutine print_attr_base(this) - ! Dummy arguments - class(cam_grid_attribute_t), intent(in) :: this - if (masterproc) then - write(iulog, '(5a)') 'Attribute: ', trim(this%name), & - ", long name = '", trim(this%long_name), "'" - end if - end subroutine print_attr_base - - subroutine cam_grid_attr_init_0d_int(this, name, long_name, val) - ! Dummy arguments - class(cam_grid_attribute_0d_int_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - integer, intent(in) :: val - - ! call this%cam_grid_attr_init(name, '') - this%name = trim(name) - this%long_name = trim(long_name) - this%ival = val - end subroutine cam_grid_attr_init_0d_int - - subroutine print_attr_0d_int(this) - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(in) :: this - - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' value = ', this%ival - end if - end subroutine print_attr_0d_int - - subroutine cam_grid_attr_init_0d_char(this, name, long_name, val) - ! Dummy arguments - class(cam_grid_attribute_0d_char_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: val - - ! call this%cam_grid_attr_init(name, '') - this%name = trim(name) - this%long_name = trim(long_name) - this%val = trim(val) - end subroutine cam_grid_attr_init_0d_char - - subroutine print_attr_0d_char(this) - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(in) :: this - - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' value = ', trim(this%val) - end if - end subroutine print_attr_0d_char - - subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & - dimsize, values, map) - ! Dummy arguments - class(cam_grid_attribute_1d_int_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - integer, target, intent(in) :: values(:) - integer(iMap), optional, target, intent(in) :: map(:) - - ! call this%cam_grid_attr_init(trim(name), trim(long_name)) - if (len_trim(name) > max_hcoordname_len) then - call endrun('cam_grid_attr_1d_int: name too long') - end if - this%name = trim(name) - if (len_trim(long_name) > max_chars) then - call endrun('cam_grid_attr_1d_int: long_name too long') - end if - this%long_name = trim(long_name) - - if (len_trim(dimname) > max_hcoordname_len) then - call endrun('cam_grid_attr_1d_int: dimname too long') - end if - this%dimname = trim(dimname) - this%dimsize = dimsize - this%values => values - ! Fill in the optional map - if (present(map)) then - allocate(this%map(size(map))) - this%map(:) = map(:) - else - nullify(this%map) - end if - end subroutine cam_grid_attr_init_1d_int - - subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & - dimsize, values, map) - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - real(r8), target, intent(in) :: values(:) - integer(iMap), optional, target, intent(in) :: map(:) - - ! call this%cam_grid_attr_init(trim(name), trim(long_name), next) - this%name = trim(name) - this%long_name = trim(long_name) - - this%dimname = trim(dimname) - this%dimsize = dimsize - this%values => values - ! Fill in the optional map - if (present(map)) then - allocate(this%map(size(map))) - this%map(:) = map(:) - else - nullify(this%map) - end if - end subroutine cam_grid_attr_init_1d_r8 - - subroutine print_attr_1d_int(this) - ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(in) :: this - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' dimname = ', trim(this%dimname) - end if - end subroutine print_attr_1d_int - - subroutine print_attr_1d_r8(this) - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(in) :: this - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' dimname = ', trim(this%dimname) - end if - end subroutine print_attr_1d_r8 - - subroutine insert_grid_attribute(gridind, attr) - integer, intent(in) :: gridind - class(cam_grid_attribute_t), pointer :: attr - - ! Push a new attribute onto the grid - type(cam_grid_attr_ptr_t), pointer :: attrPtr - - allocate(attrPtr) - call attrPtr%initialize(attr) - call attrPtr%setNext(cam_grids(gridind)%attributes) - cam_grids(gridind)%attributes => attrPtr - call attrPtr%attr%print_attr() - end subroutine insert_grid_attribute - - subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - integer, intent(in) :: val - - ! Local variables - type(cam_grid_attribute_0d_int_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_0d_int: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) - else - ! Need a new attribute. - allocate(attr) - call attr%cam_grid_attr_init_0d_int(trim(name), & - trim(long_name), val) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_int: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if - ! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_0d_int - - subroutine add_cam_grid_attribute_0d_char(gridname, name, val) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - - ! Local variables - type(cam_grid_attribute_0d_char_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_0d_char: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) - else - ! Need a new attribute. - allocate(attr) - call attr%cam_grid_attr_init_0d_char(trim(name), '', val) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_char: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if - ! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_0d_char - - subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & - dimname, values, map) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in), target :: values(:) - integer(iMap), intent(in), target, optional :: map(:) - - ! Local variables - type(cam_grid_attribute_1d_int_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - integer :: dimsize - - nullify(attr) - nullify(attptr) - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_1d_int: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) - else - ! Need a new attribute. - dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) - if (dimsize < 1) then - dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) - end if - if (dimsize < 1) then - write(errormsg, *) & - 'add_cam_grid_attribute_1d_int: attribute ', & - 'dimension ', trim(dimname), ' for ', trim(name), & - ', not found' - call endrun(errormsg) - end if - allocate(attr) - call attr%cam_grid_attr_init_1d_int(trim(name), & - trim(long_name), trim(dimname), dimsize, values, map) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_int: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if - ! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_1d_int - - subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & - dimname, values, map) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - real(r8), intent(in), target :: values(:) - integer(iMap), intent(in), target, optional :: map(:) - - ! Local variables - type(cam_grid_attribute_1d_r8_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - integer :: dimsize - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_1d_r8: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) - else - ! Need a new attribute. - dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) - if (dimsize < 1) then - dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) - end if - if (dimsize < 1) then - write(errormsg, *) & - 'add_cam_grid_attribute_1d_r8: attribute ', & - 'dimension ', trim(dimname), ' for ', trim(name), & - ', not found' - call endrun(errormsg) - end if - allocate(attr) - call attr%cam_grid_attr_init_1d_r8(trim(name), & - trim(long_name), trim(dimname), dimsize, values, map) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_r8: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if - ! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_1d_r8 - - !!####################################################################### - !! - !! CAM grid attribute pointer (list node) functions - !! - !!####################################################################### - - subroutine initializeAttrPtr(this, attr) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - class(cam_grid_attribute_t), target :: attr - - if (associated(this%next)) then - if (masterproc) then - write(iulog, *) 'WARNING: Overwriting attr pointer for ', & - 'cam_grid_attr_ptr_t' - end if - end if - this%attr => attr - end subroutine initializeAttrPtr - - function getAttrPtrAttr(this) - ! Dummy variable - class(cam_grid_attr_ptr_t) :: this - class(cam_grid_attribute_t), pointer :: getAttrPtrAttr - - getAttrPtrAttr => this%attr - end function getAttrPtrAttr - - function getAttrPtrNext(this) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - type(cam_grid_attr_ptr_t), pointer :: getAttrPtrNext - - getAttrPtrNext => this%next - end function getAttrPtrNext - - subroutine setAttrPtrNext(this, next) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - type(cam_grid_attr_ptr_t), pointer :: next - - if (associated(this%next)) then - if (masterproc) then - write(iulog, *) 'WARNING: Overwriting next pointer for cam_grid_attr_ptr_t' - end if - end if - this%next => next - end subroutine setAttrPtrNext - - !------------------------------------------------------------------------ - ! - ! write_cam_grid_attr_0d_int - ! - ! Write a grid attribute - ! - !------------------------------------------------------------------------ - - subroutine write_cam_grid_attr_0d_int(attr, File) - use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, & - pio_inq_att, PIO_GLOBAL - use cam_pio_utils, only: cam_pio_def_var - - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file - - ! Local variables - integer :: attrtype - integer(imap) :: attrlen - integer :: ierr - character(len=*), parameter :: subname = 'write_cam_grid_attr_0d_int' - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc)) then - if (len_trim(attr%long_name) > 0) then - ! This 0d attribute is a scalar variable with a - ! long_name attribute - ! First, define the variable - allocate(attr%vardesc) - call cam_pio_def_var(File, trim(attr%name), pio_int, & - attr%vardesc, existOK=.false.) - ierr= pio_put_att(File, attr%vardesc, '_FillValue', & - int(grid_fill_value)) - call cam_pio_handle_error(ierr, & - 'Error writing "_FillValue" attr in '//subname) - ierr=pio_put_att(File, attr%vardesc, 'long_name', & - trim(attr%long_name)) - call cam_pio_handle_error(ierr, & - 'Error writing "long_name" attr in '//subname) - else - ! This 0d attribute is a global attribute - ! Check to see if the attribute already exists in the file - ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, & - attrlen) - if (ierr /= PIO_NOERR) then - ! Time to define the attribute - ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), & - attr%ival) - call cam_pio_handle_error(ierr, & - 'Unable to define attribute in '//subname) - end if - end if - end if - - end subroutine write_cam_grid_attr_0d_int - - !------------------------------------------------------------------------ - ! - ! write_cam_grid_attr_0d_char - ! - ! Write a grid attribute - ! - !------------------------------------------------------------------------ - - subroutine write_cam_grid_attr_0d_char(attr, File) - use pio, only: file_desc_t, pio_put_att, pio_noerr, & - pio_inq_att, PIO_GLOBAL - - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file - - ! Local variables - integer :: attrtype - integer(imap) :: attrlen - integer :: ierr - character(len=*), parameter :: subname = 'write_cam_grid_attr_0d_char' - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc)) then - ! The 0d char attributes are global attribues - ! Check to see if the attribute already exists in the file - ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) - if (ierr /= PIO_NOERR) then - ! Time to define the variable - ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%val) - call cam_pio_handle_error(ierr, & - 'Unable to define attribute in '//subname) - end if - end if - - end subroutine write_cam_grid_attr_0d_char - - !------------------------------------------------------------------------ - ! - ! write_cam_grid_attr_1d_int - ! - ! Write a grid attribute - ! - !------------------------------------------------------------------------ - - subroutine write_cam_grid_attr_1d_int(attr, File) - use pio, only: file_desc_t, pio_put_att, pio_noerr - use pio, only: pio_inq_dimid, pio_int - use cam_pio_utils, only: cam_pio_def_var - - ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file - - ! Local variables - integer :: dimid ! PIO dimension ID - character(len=120) :: errormsg - integer :: ierr - character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_int' - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc)) then - ! Check to see if the dimension already exists in the file - ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) - if (ierr /= PIO_NOERR) then - ! The dimension has not yet been defined. This is an error - ! NB: It should have been defined as part of a coordinate - write(errormsg, *) 'write_cam_grid_attr_1d_int: dimension, ', & - trim(attr%dimname), ', does not exist' - call endrun(errormsg) - end if - ! Time to define the variable - allocate(attr%vardesc) - call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), & - attr%vardesc, existOK=.false.) - ierr = pio_put_att(File, attr%vardesc, '_FillValue', & - int(grid_fill_value)) - call cam_pio_handle_error(ierr, & - 'Error writing "_FillValue" attr in '//subname) - ierr = pio_put_att(File, attr%vardesc, 'long_name', & - trim(attr%long_name)) - call cam_pio_handle_error(ierr, & - 'Error writing "long_name" attr in '//subname) - end if - - end subroutine write_cam_grid_attr_1d_int - - !------------------------------------------------------------------------ - ! - ! write_cam_grid_attr_1d_r8 - ! - ! Write a grid attribute - ! - !------------------------------------------------------------------------ - - subroutine write_cam_grid_attr_1d_r8(attr, File) - use pio, only: file_desc_t, pio_put_att, pio_noerr - use pio, only: pio_double, pio_inq_dimid - use cam_pio_utils, only: cam_pio_def_var - - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file - - ! Local variables - integer :: dimid ! PIO dimension ID - character(len=120) :: errormsg - integer :: ierr - character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_r8' - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc)) then - ! Check to see if the dimension already exists in the file - ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) - if (ierr /= PIO_NOERR) then - ! The dimension has not yet been defined. This is an error - ! NB: It should have been defined as part of a coordinate - write(errormsg, *) 'write_cam_grid_attr_1d_r8: dimension, ', & - trim(attr%dimname), ', does not exist' - call endrun(errormsg) - end if - ! Time to define the variable - allocate(attr%vardesc) - call cam_pio_def_var(File, trim(attr%name), pio_double, & - (/dimid/), attr%vardesc, existOK=.false.) - ! fill value - ierr = pio_put_att(File, attr%vardesc, '_FillValue', & - grid_fill_value) - call cam_pio_handle_error(ierr, & - 'Error writing "_FillValue" attr in '//subname) - ! long_name - ierr = pio_put_att(File, attr%vardesc, 'long_name', & - trim(attr%long_name)) - call cam_pio_handle_error(ierr, & - 'Error writing "long_name" attr in '//subname) - end if - - end subroutine write_cam_grid_attr_1d_r8 - - !------------------------------------------------------------------------ - ! - ! cam_grid_attribute_copy - ! - ! Copy an attribute from a source grid to a destination grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name) - ! Dummy arguments - character(len=*), intent(in) :: src_grid - character(len=*), intent(in) :: dest_grid - character(len=*), intent(in) :: attribute_name - - ! Local variables - character(len=120) :: errormsg - integer :: src_ind, dest_ind - class(cam_grid_attribute_t), pointer :: attr - - ! Find the source and destination grid indices - src_ind = get_cam_grid_index(trim(src_grid)) - dest_ind = get_cam_grid_index(trim(dest_grid)) - - call find_cam_grid_attr(dest_ind, trim(attribute_name), attr) - if (associated(attr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') 'CAM_GRID_ATTRIBUTE_COPY: attribute ', & - trim(attribute_name), ' already exists for ', & - cam_grids(dest_ind)%name - call endrun(errormsg) - else - call find_cam_grid_attr(src_ind, trim(attribute_name), attr) - if (associated(attr)) then - ! Copy the attribute - call insert_grid_attribute(dest_ind, attr) - else - write(errormsg, '(4a)') ": Did not find attribute, '", & - trim(attribute_name), "' in ", cam_grids(src_ind)%name - call endrun("CAM_GRID_ATTRIBUTE_COPY"//errormsg) - end if - end if - - end subroutine cam_grid_attribute_copy - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_attr - ! - ! Write the dimension and coordinate attributes for the horizontal - ! history coordinates. - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_attr(File, grid_id, header_info) - use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling - use pio, only: pio_inq_dimid - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, intent(in) :: grid_id - type(cam_grid_header_info_t), intent(inout) :: header_info - - ! Local variables - integer :: gridind - class(cam_grid_attribute_t), pointer :: attr - type(cam_grid_attr_ptr_t), pointer :: attrPtr - integer :: dimids(2) - integer :: err_handling - - gridind = get_cam_grid_index(grid_id) - !! Fill this in to make sure history finds grid - header_info%grid_id = grid_id - - if (allocated(header_info%hdims)) then - ! This shouldn't happen but, no harm, no foul - deallocate(header_info%hdims) - end if - - if (associated(header_info%lon_varid)) then - ! This could be a sign of bad memory management - call endrun('CAM_GRID_WRITE_ATTR: lon_varid should be NULL') - end if - if (associated(header_info%lat_varid)) then - ! This could be a sign of bad memory management - call endrun('CAM_GRID_WRITE_ATTR: lat_varid should be NULL') - end if - - ! Only write this grid if not already defined - if (cam_grids(gridind)%attrs_defined) then - ! We need to fill out the hdims info for this grid - call cam_grids(gridind)%find_dimids(File, dimids) - if (dimids(2) < 0) then - allocate(header_info%hdims(1)) - header_info%hdims(1) = dimids(1) - else - allocate(header_info%hdims(2)) - header_info%hdims(1:2) = dimids(1:2) - end if - else - ! Write the horizontal coord attributes first so that we have - ! the dims - call cam_grids(gridind)%lat_coord%write_attr(File, dimids(2)) - call cam_grids(gridind)%lon_coord%write_attr(File, dimids(1)) - - if (dimids(2) == dimids(1)) then - allocate(header_info%hdims(1)) - else - allocate(header_info%hdims(2)) - header_info%hdims(2) = dimids(2) - end if - header_info%hdims(1) = dimids(1) - - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR, & - oldmethod=err_handling) - - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) - !!XXgoldyXX: Is this not working in PGI? - ! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%write_attr(File) - !!XXgoldyXX: Is this not working in PGI? - ! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - - ! Back to previous I/O error handling - call pio_seterrorhandling(File, err_handling) - - cam_grids(gridind)%attrs_defined = .true. - end if - - end subroutine cam_grid_write_attr - - subroutine write_cam_grid_val_0d_int(attr, File) - use pio, only: file_desc_t, pio_inq_varid, pio_put_var - - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - - ! Local variables - integer :: ierr - character(len=*), parameter :: subname = 'write_cam_grid_val_0d_int' - - ! We only write this var if it is a variable - if (associated(attr%vardesc)) then - ierr = pio_put_var(File, attr%vardesc, attr%ival) - call cam_pio_handle_error(ierr, 'Error writing value in '//subname) - deallocate(attr%vardesc) - nullify(attr%vardesc) - end if - - end subroutine write_cam_grid_val_0d_int - - subroutine write_cam_grid_val_0d_char(attr, File) + use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4, max_chars=>shr_kind_cl + use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4 + use shr_sys_mod, only: shr_sys_flush + use pio, only: iMap=>PIO_OFFSET_KIND, var_desc_t + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use cam_pio_utils, only: cam_pio_handle_error + use cam_map_utils, only: cam_filemap_t + + implicit none + private + + public iMap + + integer, parameter, public :: max_hcoordname_len = 16 + integer, parameter, public :: max_split_files = 2 + + type, public :: vardesc_ptr_t + type(var_desc_t), pointer :: p => NULL() + end type vardesc_ptr_t + !--------------------------------------------------------------------------- + ! + ! horiz_coord_t: Information for horizontal dimension attributes + ! + !--------------------------------------------------------------------------- + type, public :: horiz_coord_t + private + character(len=max_hcoordname_len) :: name = '' ! coordinate name + character(len=max_hcoordname_len) :: dimname = '' ! dimension name + ! NB: If dimname is blank, it is assumed to be name + integer :: dimsize = 0 ! global size of dimension + character(len=max_chars) :: long_name = '' ! 'long_name' attribute + character(len=max_chars) :: units = '' ! 'units' attribute + real(r8), pointer :: values(:) => NULL() ! dim values (local if map) + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for dist. coord + logical :: latitude ! .false. means longitude + real(r8), pointer :: bnds(:,:) => NULL() ! bounds, if present + type(vardesc_ptr_t) :: vardesc(max_split_files) ! If we are to write coord + type(vardesc_ptr_t) :: bndsvdesc(max_split_files) ! If we are to write bounds + contains + procedure :: get_coord_len => horiz_coord_len + procedure :: num_elem => horiz_coord_num_elem + procedure :: global_size => horiz_coord_find_size + procedure :: get_coord_name => horiz_coord_name + procedure :: get_dim_name => horiz_coord_dim_name + procedure :: get_long_name => horiz_coord_long_name + procedure :: get_units => horiz_coord_units + procedure :: write_attr => write_horiz_coord_attr + procedure :: write_var => write_horiz_coord_var + end type horiz_coord_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_t: Auxiliary quantity for a CAM grid + ! + !--------------------------------------------------------------------------- + type, abstract :: cam_grid_attribute_t + character(len=max_hcoordname_len) :: name = '' ! attribute name + character(len=max_chars) :: long_name = '' ! attribute long_name + type(vardesc_ptr_t) :: vardesc(max_split_files) +! We aren't going to use this until we sort out PGI issues + class(cam_grid_attribute_t), pointer :: next => NULL() + contains + procedure :: cam_grid_attr_init + procedure(write_cam_grid_attr), deferred :: write_attr + procedure(write_cam_grid_attr), deferred :: write_val + procedure(print_attr_spec), deferred :: print_attr + procedure :: print_attr_base + end type cam_grid_attribute_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_0d_int_t: Global integral attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_int_t + integer :: ival + contains + procedure :: cam_grid_attr_init_0d_int + procedure :: write_attr => write_cam_grid_attr_0d_int + procedure :: write_val => write_cam_grid_val_0d_int + procedure :: print_attr => print_attr_0d_int + end type cam_grid_attribute_0d_int_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_0d_char_t: Global string attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_char_t + character(len=max_chars) :: val + contains + procedure :: cam_grid_attr_init_0d_char + procedure :: write_attr => write_cam_grid_attr_0d_char + procedure :: write_val => write_cam_grid_val_0d_char + procedure :: print_attr => print_attr_0d_char + end type cam_grid_attribute_0d_char_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_1d_int_t: 1-d integer attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_int_t + character(len=max_hcoordname_len) :: dimname ! attribute dimension + integer :: dimsize ! Global array/map size + integer, pointer :: values(:) => NULL() + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O + contains + procedure :: cam_grid_attr_init_1d_int + procedure :: write_attr => write_cam_grid_attr_1d_int + procedure :: write_val => write_cam_grid_val_1d_int + procedure :: print_attr => print_attr_1d_int + end type cam_grid_attribute_1d_int_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_1d_r8_t: 1-d real*8 attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_r8_t + character(len=max_hcoordname_len) :: dimname ! attribute dimension + integer :: dimsize ! Global array/map size + real(r8), pointer :: values(:) => NULL() + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O + contains + procedure :: cam_grid_attr_init_1d_r8 + procedure :: write_attr => write_cam_grid_attr_1d_r8 + procedure :: write_val => write_cam_grid_val_1d_r8 + procedure :: print_attr => print_attr_1d_r8 + end type cam_grid_attribute_1d_r8_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attr_ptr_t: linked list of CAM grid attributes + ! + !--------------------------------------------------------------------------- + type :: cam_grid_attr_ptr_t + private + class(cam_grid_attribute_t), pointer :: attr => NULL() + type(cam_grid_attr_ptr_t), pointer :: next => NULL() + contains + private + procedure, public :: initialize => initializeAttrPtr + procedure, public :: getAttr => getAttrPtrAttr + procedure, public :: getNext => getAttrPtrNext + procedure, public :: setNext => setAttrPtrNext + end type cam_grid_attr_ptr_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_t: Information for a CAM grid (defined by a dycore) + ! + !--------------------------------------------------------------------------- + type :: cam_grid_t + character(len=max_hcoordname_len) :: name = '' ! grid name + integer :: id ! e.g., dyn_decomp + type(horiz_coord_t), pointer :: lat_coord => NULL() ! Latitude coord + type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude coord + logical :: unstructured ! Is this needed? + logical :: block_indexed ! .false. for lon/lat + logical :: attrs_defined(2) = .false. + logical :: zonal_grid = .false. + type(cam_filemap_t), pointer :: map => null() ! global dim map (dof) + type(cam_grid_attr_ptr_t), pointer :: attributes => NULL() + contains + procedure :: print_cam_grid + procedure :: is_unstructured => cam_grid_unstructured + procedure :: is_block_indexed => cam_grid_block_indexed + procedure :: is_zonal_grid => cam_grid_zonal_grid + procedure :: coord_lengths => cam_grid_get_dims + procedure :: coord_names => cam_grid_coord_names + procedure :: dim_names => cam_grid_dim_names + procedure :: num_elem => cam_grid_local_size + procedure :: set_map => cam_grid_set_map + procedure :: get_patch_mask => cam_grid_get_patch_mask + procedure :: get_lon_lat => cam_grid_get_lon_lat + procedure :: find_src_dims => cam_grid_find_src_dims + procedure :: find_dest_dims => cam_grid_find_dest_dims + procedure :: find_dimids => cam_grid_find_dimids + procedure :: get_decomp => cam_grid_get_pio_decomp + procedure :: read_darray_2d_int => cam_grid_read_darray_2d_int + procedure :: read_darray_3d_int => cam_grid_read_darray_3d_int + procedure :: read_darray_2d_double => cam_grid_read_darray_2d_double + procedure :: read_darray_3d_double => cam_grid_read_darray_3d_double + procedure :: read_darray_2d_real => cam_grid_read_darray_2d_real + procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real + procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int + procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int + procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double + procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double + procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real + procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real + end type cam_grid_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_patch_t: Information for a patch of a CAM grid + ! + !--------------------------------------------------------------------------- + type, public :: cam_grid_patch_t + private + integer :: grid_id = -1 ! grid containing patch points + integer :: global_size = 0 ! var patch dim size + integer :: global_lat_size = 0 ! lat patch dim size + integer :: global_lon_size = 0 ! lon patch dim size + integer :: num_points = 0 ! task-local size + real(r8) :: lon_range(2) + real(r8) :: lat_range(2) + logical :: collected_columns ! Output unstructured + type(cam_filemap_t), pointer :: mask => null() ! map for active pts + integer(iMap), pointer :: latmap(:) => null() ! map for patch coords + integer(iMap), pointer :: lonmap(:) => null() ! map for patch coords + real(r8), pointer :: lonvals(:) => null() ! For collected output + real(r8), pointer :: latvals(:) => null() ! For collected output + contains + procedure :: gridid => cam_grid_patch_get_id + procedure :: get_axis_names => cam_grid_patch_get_axis_names + procedure :: get_coord_long_name => cam_grid_patch_get_coord_long_name + procedure :: get_coord_units => cam_grid_patch_get_coord_units + procedure :: set_patch => cam_grid_patch_set_patch + procedure :: get_decomp => cam_grid_patch_get_decomp + procedure :: compact => cam_grid_patch_compact + procedure :: active_cols => cam_grid_patch_get_active_cols + procedure :: write_coord_vals => cam_grid_patch_write_vals + procedure :: grid_index => cam_grid_patch_get_grid_index + procedure :: deallocate => cam_grid_patch_deallocate +!!XXgoldyXX: PGI workaround? +! COMPILER_BUG(goldy, 2014-11-28, pgi <= 14.9); Commented code should work +! procedure :: global_size_map => cam_grid_patch_get_global_size_map +! procedure :: global_size_axes => cam_grid_patch_get_global_size_axes +! generic :: get_global_size => global_size_map, global_size_axes + procedure :: cam_grid_patch_get_global_size_map + procedure :: cam_grid_patch_get_global_size_axes + generic :: get_global_size => cam_grid_patch_get_global_size_map, cam_grid_patch_get_global_size_axes + end type cam_grid_patch_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_header_info_t: Hold NetCDF dimension information for a CAM grid + ! + !--------------------------------------------------------------------------- + type, public :: cam_grid_header_info_t + private + integer :: grid_id = -1 ! e.g., dyn_decomp + integer, allocatable :: hdims(:) ! horizontal dimension ids + type(var_desc_t), pointer :: lon_varid => NULL() ! lon coord variable + type(var_desc_t), pointer :: lat_varid => NULL() ! lat coord variable + contains + procedure :: get_gridid => cam_grid_header_info_get_gridid + procedure :: set_gridid => cam_grid_header_info_set_gridid + procedure :: set_hdims => cam_grid_header_info_set_hdims + procedure :: num_hdims => cam_grid_header_info_num_hdims + procedure :: get_hdimid => cam_grid_header_info_hdim + !!XXgoldyXX: Maybe replace this with horiz_coords for patches? + procedure :: set_varids => cam_grid_header_info_set_varids + procedure :: get_lon_varid => cam_grid_header_info_lon_varid + procedure :: get_lat_varid => cam_grid_header_info_lat_varid + procedure :: deallocate => cam_grid_header_info_deallocate + end type cam_grid_header_info_t + + !--------------------------------------------------------------------------- + ! + ! END: types BEGIN: interfaces for types + ! + !--------------------------------------------------------------------------- + + ! Abstract interface for write_attr procedure of cam_grid_attribute_t class + ! NB: This will not compile on some pre-13 Intel compilers + ! (fails on 12.1.0.233 on Frankfurt, passes on 13.0.1.117 on Yellowstone) + abstract interface + subroutine write_cam_grid_attr(attr, File, file_index) use pio, only: file_desc_t - - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - - ! This subroutine is a stub because global attributes are written - ! in define mode - return - end subroutine write_cam_grid_val_0d_char - - subroutine write_cam_grid_val_1d_int(attr, File) - use pio, only: file_desc_t, pio_put_var, pio_int, io_desc_t - use pio, only: pio_inq_varid, pio_write_darray - use pio, only: pio_freedecomp - use cam_pio_utils, only: cam_pio_newdecomp - + import :: cam_grid_attribute_t ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - - ! Local variables - integer :: ierr - type(io_desc_t), pointer :: iodesc - character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' - - nullify(iodesc) - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is not associated, another grid write the values - if (associated(attr%vardesc)) then - ! Write out the values for this dimension variable - if (associated(attr%map)) then - ! This is a distributed variable, use pio_write_darray - allocate(iodesc) - call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & - pio_int) - call pio_write_darray(File, attr%vardesc, iodesc, attr%values, & - ierr) - call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) - else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, attr%vardesc, attr%values) - end if - call cam_pio_handle_error(ierr, & - 'Error writing variable values in '//subname) - deallocate(attr%vardesc) - nullify(attr%vardesc) - end if - - end subroutine write_cam_grid_val_1d_int - - subroutine write_cam_grid_val_1d_r8(attr, File) - use pio, only: file_desc_t, pio_put_var, pio_double - use pio, only: pio_inq_varid, pio_write_darray - use pio, only: io_desc_t, pio_freedecomp - use cam_pio_utils, only: cam_pio_newdecomp - + class(cam_grid_attribute_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + end subroutine write_cam_grid_attr + end interface + + ! Abstract interface for print_attr procedure of cam_grid_attribute_t class + abstract interface + subroutine print_attr_spec(this) + import :: cam_grid_attribute_t ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - - ! Local variables - integer :: ierr - type(io_desc_t), pointer :: iodesc - character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' - - nullify(iodesc) - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is not associated, another grid write the values - if (associated(attr%vardesc)) then - ! Write out the values for this dimension variable - if (associated(attr%map)) then - ! This is a distributed variable, use pio_write_darray - allocate(iodesc) - call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & - pio_double) - call pio_write_darray(File, attr%vardesc, iodesc, attr%values, & - ierr) - call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) - else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, attr%vardesc, attr%values) - end if - call cam_pio_handle_error(ierr, & - 'Error writing variable values in '//subname) - deallocate(attr%vardesc) - nullify(attr%vardesc) - end if + class(cam_grid_attribute_t), intent(in) :: this + end subroutine print_attr_spec + end interface + + !! Grid variables + integer, parameter :: maxhgrids = 16 ! arbitrary limit + integer, save :: registeredhgrids = 0 + type(cam_grid_t), save :: cam_grids(maxhgrids) + + public :: horiz_coord_create + + ! Setup and I/O functions for grids rely on the grid's ID, not its index. + public :: cam_grid_register, cam_grid_attribute_register + public :: cam_grid_attribute_copy + public :: cam_grid_write_attr, cam_grid_write_var + public :: cam_grid_read_dist_array, cam_grid_write_dist_array + ! Access functions for grids rely on the grid's ID or name, not its index. + public :: cam_grid_dimensions, cam_grid_num_grids + public :: cam_grid_check ! T/F if grid ID exists + public :: cam_grid_id ! Grid ID (decomp) or -1 if error + public :: cam_grid_get_local_size + public :: cam_grid_get_file_dimids + public :: cam_grid_get_decomp + public :: cam_grid_get_gcid + public :: cam_grid_get_array_bounds + public :: cam_grid_get_coord_names, cam_grid_get_dim_names + public :: cam_grid_has_blocksize, cam_grid_get_block_count + public :: cam_grid_get_latvals, cam_grid_get_lonvals + public :: cam_grid_get_coords + public :: cam_grid_is_unstructured, cam_grid_is_block_indexed + public :: cam_grid_attr_exists + public :: cam_grid_is_zonal + ! Functions for dealing with patch masks + public :: cam_grid_compute_patch + ! Functions for dealing with grid areas + public :: cam_grid_get_areawt + + interface cam_grid_attribute_register + module procedure add_cam_grid_attribute_0d_int + module procedure add_cam_grid_attribute_0d_char + module procedure add_cam_grid_attribute_1d_int + module procedure add_cam_grid_attribute_1d_r8 + end interface + + interface cam_grid_dimensions + module procedure cam_grid_dimensions_id + module procedure cam_grid_dimensions_name + end interface + + interface cam_grid_get_dim_names + module procedure cam_grid_get_dim_names_id + module procedure cam_grid_get_dim_names_name + end interface + + interface cam_grid_read_dist_array + module procedure cam_grid_read_dist_array_2d_int + module procedure cam_grid_read_dist_array_3d_int + module procedure cam_grid_read_dist_array_2d_double + module procedure cam_grid_read_dist_array_3d_double + module procedure cam_grid_read_dist_array_2d_real + module procedure cam_grid_read_dist_array_3d_real + end interface + + interface cam_grid_write_dist_array + module procedure cam_grid_write_dist_array_2d_int + module procedure cam_grid_write_dist_array_3d_int + module procedure cam_grid_write_dist_array_2d_double + module procedure cam_grid_write_dist_array_3d_double + module procedure cam_grid_write_dist_array_2d_real + module procedure cam_grid_write_dist_array_3d_real + end interface + + ! Private interfaces + interface get_cam_grid_index + module procedure get_cam_grid_index_char ! For lookup by name + module procedure get_cam_grid_index_int ! For lookup by ID + end interface - end subroutine write_cam_grid_val_1d_r8 +contains - subroutine cam_grid_write_var(File, grid_id) - use pio, only: file_desc_t, pio_bcast_error, pio_seterrorhandling +!!####################################################################### +!! +!! Horizontal coordinate functions +!! +!!####################################################################### - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, intent(in) :: grid_id - - ! Local variables - integer :: gridind - integer :: err_handling - class(cam_grid_attribute_t), pointer :: attr - type(cam_grid_attr_ptr_t), pointer :: attrPtr - - gridind = get_cam_grid_index(grid_id) - ! Only write if not already done - if (cam_grids(gridind)%attrs_defined) then - ! Write the horizontal coorinate values - call cam_grids(gridind)%lon_coord%write_var(File) - call cam_grids(gridind)%lat_coord%write_var(File) - - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR, & - oldmethod=err_handling) - - ! Write out the variable values for each grid attribute - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) - !!XXgoldyXX: Is this not working in PGI? - ! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%write_val(File) - !!XXgoldyXX: Is this not working in PGI? - ! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - - ! Back to previous I/O error handling - call pio_seterrorhandling(File, err_handling) - - cam_grids(gridind)%attrs_defined = .false. + integer function horiz_coord_find_size(this, dimname) result(dimsize) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(in) :: dimname + + dimsize = -1 + if (len_trim(this%dimname) == 0) then + if(trim(dimname) == trim(this%name)) then + dimsize = this%dimsize + end if + else + if(trim(dimname) == trim(this%dimname)) then + dimsize = this%dimsize + end if + end if + + end function horiz_coord_find_size + + integer function horiz_coord_num_elem(this) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + + if (associated(this%values)) then + horiz_coord_num_elem = size(this%values) + else + horiz_coord_num_elem = 0 + end if + + end function horiz_coord_num_elem + + subroutine horiz_coord_len(this, clen) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + integer, intent(out) :: clen + + clen = this%dimsize + end subroutine horiz_coord_len + + subroutine horiz_coord_name(this, name) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: name + + if (len(name) < len_trim(this%name)) then + call endrun('horiz_coord_name: input name too short') + end if + name = trim(this%name) + end subroutine horiz_coord_name + + subroutine horiz_coord_dim_name(this, dimname) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: dimname + + if (len_trim(this%dimname) > 0) then + ! We have a separate dimension name (e.g., ncol) + if (len(dimname) < len_trim(this%dimname)) then + call endrun('horiz_coord_dimname: input name too short') + end if + dimname = trim(this%dimname) + else + ! No dimension name so we use the coordinate's name + ! i.e., The dimension name is the same as the coordinate variable + if (len(dimname) < len_trim(this%name)) then + call endrun('horiz_coord_dimname: input name too short') + end if + dimname = trim(this%name) + end if + end subroutine horiz_coord_dim_name + + subroutine horiz_coord_long_name(this, name) + + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: name + + if (len(name) < len_trim(this%long_name)) then + call endrun('horiz_coord_long_name: input name too short') + else + name = trim(this%long_name) + end if + + end subroutine horiz_coord_long_name + + subroutine horiz_coord_units(this, units) + + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: units + + if (len(units) < len_trim(this%units)) then + call endrun('horiz_coord_units: input units too short') + else + units = trim(this%units) + end if + + end subroutine horiz_coord_units + + function horiz_coord_create(name, dimname, dimsize, long_name, units, & + lbound, ubound, values, map, bnds) result(newcoord) + + ! Dummy arguments + character(len=*), intent(in) :: name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + ! NB: Sure, pointers would have made sense but . . . PGI + integer, intent(in) :: lbound + integer, intent(in) :: ubound + real(r8), intent(in) :: values(lbound:ubound) + integer(iMap), intent(in), optional :: map(ubound-lbound+1) + real(r8), intent(in), optional :: bnds(2,lbound:ubound) + type(horiz_coord_t), pointer :: newcoord + + allocate(newcoord) + + newcoord%name = trim(name) + newcoord%dimname = trim(dimname) + newcoord%dimsize = dimsize + newcoord%long_name = trim(long_name) + newcoord%units = trim(units) + ! Figure out if this is a latitude or a longitude using CF standard + ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#latitude-coordinate + ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#longitude-coordinate + if ( (trim(units) == 'degrees_north') .or. & + (trim(units) == 'degree_north') .or. & + (trim(units) == 'degree_N') .or. & + (trim(units) == 'degrees_N') .or. & + (trim(units) == 'degreeN') .or. & + (trim(units) == 'degreesN')) then + newcoord%latitude = .true. + else if ((trim(units) == 'degrees_east') .or. & + (trim(units) == 'degree_east') .or. & + (trim(units) == 'degree_E') .or. & + (trim(units) == 'degrees_E') .or. & + (trim(units) == 'degreeE') .or. & + (trim(units) == 'degreesE')) then + newcoord%latitude = .false. + else + call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'") + end if + allocate(newcoord%values(lbound:ubound)) + if (ubound >= lbound) then + newcoord%values(:) = values(:) + end if + + if (present(map)) then + if (ANY(map < 0)) then + call endrun("horiz_coord_create "//trim(name)//": map vals < 0") + end if + allocate(newcoord%map(ubound - lbound + 1)) + if (ubound >= lbound) then + newcoord%map(:) = map(:) end if + else + nullify(newcoord%map) + end if - end subroutine cam_grid_write_var - - logical function cam_grid_block_indexed(this) - class(cam_grid_t) :: this - - cam_grid_block_indexed = this%block_indexed - end function cam_grid_block_indexed - - logical function cam_grid_zonal_grid(this) - class(cam_grid_t) :: this - - cam_grid_zonal_grid = this%zonal_grid - end function cam_grid_zonal_grid - - logical function cam_grid_unstructured(this) - class(cam_grid_t) :: this - - cam_grid_unstructured = this%unstructured - end function cam_grid_unstructured - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_dims: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_dims(this, dims) - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(inout) :: dims(2) + if (present(bnds)) then + allocate(newcoord%bnds(2, lbound:ubound)) + if (ubound >= lbound) then + newcoord%bnds = bnds + end if + else + nullify(newcoord%bnds) + end if + + end function horiz_coord_create + + !--------------------------------------------------------------------------- + ! + ! write_horiz_coord_attr + ! + ! Write the dimension and coordinate attributes for a horizontal grid + ! coordinate. + ! + !--------------------------------------------------------------------------- + + subroutine write_horiz_coord_attr(this, File, dimid_out, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double + use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Dummy arguments + class(horiz_coord_t), intent(inout) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(out) :: dimid_out + integer, optional, intent(in) :: file_index + + ! Local variables + type(var_desc_t) :: vardesc + character(len=max_hcoordname_len) :: dimname + integer :: dimid ! PIO dimension ID + integer :: bnds_dimid ! PIO dim ID for bounds + integer :: err_handling + integer :: ierr + integer :: file_index_loc + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Make sure the dimension exists in the file + call this%get_dim_name(dimname) + call cam_pio_def_dim(File, trim(dimname), this%dimsize, dimid, & + existOK=.true.) + ! Should we define the variable? + ierr = pio_inq_varid(File, trim(this%name), vardesc) + if (ierr /= PIO_NOERR) then + ! Variable not already defined, it is up to us to define the variable + if (associated(this%vardesc(file_index_loc)%p)) then + ! This should not happen (i.e., internal error) + call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname)) + end if + allocate(this%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(this%name), pio_double, & + (/ dimid /), this%vardesc(file_index_loc)%p, existOK=.false.) + ! long_name + ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'long_name', trim(this%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_horiz_coord_attr') + ! units + ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'units', trim(this%units)) + call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_horiz_coord_attr') + ! Take care of bounds if they exist + if (associated(this%bnds)) then + allocate(this%bndsvdesc(file_index_loc)%p) + ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'bounds', trim(this%name)//'_bnds') + call cam_pio_handle_error(ierr, 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr') + call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.) + call cam_pio_def_var(File, trim(this%name)//'_bnds', pio_double, & + (/ bnds_dimid, dimid /), this%bndsvdesc(file_index_loc)%p, existOK=.false.) + call cam_pio_handle_error(ierr, 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr') + ! long_name + ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'long_name', trim(this%name)//' bounds') + call cam_pio_handle_error(ierr, 'Error writing bounds "long_name" attr in write_horiz_coord_attr') + ! units + ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'units', trim(this%units)) + call cam_pio_handle_error(ierr, 'Error writing bounds "units" attr in write_horiz_coord_attr') + end if ! There are bounds for this coordinate + end if ! We define the variable + + if (present(dimid_out)) then + dimid_out = dimid + end if + + ! Back to old error handling + call pio_seterrorhandling(File, err_handling) + + end subroutine write_horiz_coord_attr + + !--------------------------------------------------------------------------- + ! + ! write_horiz_coord_var + ! + ! Write the coordinate values for this coordinate + ! + !--------------------------------------------------------------------------- + + subroutine write_horiz_coord_var(this, File, file_index) + use cam_pio_utils, only: cam_pio_get_decomp + use pio, only: file_desc_t, pio_double, iosystem_desc_t + use pio, only: pio_put_var, pio_write_darray + use pio, only: pio_bcast_error, pio_seterrorhandling + !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! + !!XXgoldyXX: The issue is cam_pio_utils depending on stuff in this module + use pio, only: pio_initdecomp, io_desc_t, pio_freedecomp, pio_syncfile + use cam_instance, only: atm_id + use shr_pio_mod, only: shr_pio_getiosys + !!XXgoldyXX: End of this part of the hack + + ! Dummy arguments + class(horiz_coord_t), intent(inout) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + character(len=120) :: errormsg + integer :: ierr + integer :: ldims(1) + integer :: fdims(1) + integer :: err_handling + type(io_desc_t) :: iodesc + integer :: file_index_loc + !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! + type(iosystem_desc_t), pointer :: piosys + !!XXgoldyXX: End of this part of the hack + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Check to make sure we are supposed to write this var + if (associated(this%vardesc(file_index_loc)%p)) then + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) - if (this%is_unstructured()) then - call this%lon_coord%get_coord_len(dims(1)) - dims(2) = 1 + ! Write out the values for this dimension variable + if (associated(this%map)) then + ! This is a distributed variable, use pio_write_darray +#if 0 + ldims(1) = this%num_elem() + call this%get_coord_len(fdims(1)) + allocate(iodesc) + call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr) + nullify(iodesc) ! CAM PIO system takes over memory management of iodesc +#else + !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! + piosys => shr_pio_getiosys(atm_id) + call pio_initdecomp(piosys, pio_double, (/this%dimsize/), this%map, & + iodesc) + call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr) + + call pio_syncfile(File) + call pio_freedecomp(File, iodesc) + ! Take care of bounds if they exist + if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then + call pio_initdecomp(piosys, pio_double, (/2, this%dimsize/), & + this%map, iodesc) + call pio_write_darray(File, this%bndsvdesc(file_index_loc)%p, iodesc, this%bnds, ierr) + call pio_syncfile(File) + call pio_freedecomp(File, iodesc) + end if +#endif + !!XXgoldyXX: End of this part of the hack else - call this%lon_coord%get_coord_len(dims(1)) - call this%lat_coord%get_coord_len(dims(2)) + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, this%vardesc(file_index_loc)%p, this%values) + ! Take care of bounds if they exist + if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then + ierr = pio_put_var(File, this%bndsvdesc(file_index_loc)%p, this%bnds) + end if end if + write(errormsg, *) 'Error writing variable values for ',trim(this%name),& + ' in write_horiz_coord_var' + call cam_pio_handle_error(ierr, errormsg) - end subroutine cam_grid_get_dims + ! Back to old error handling + call pio_seterrorhandling(File, err_handling) - !------------------------------------------------------------------------ - ! - ! cam_grid_coord_names: Return the names of the grid axes - ! - !------------------------------------------------------------------------ - subroutine cam_grid_coord_names(this, lon_name, lat_name) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: lat_name - - call this%lon_coord%get_coord_name(lon_name) - call this%lat_coord%get_coord_name(lat_name) - - end subroutine cam_grid_coord_names - - !------------------------------------------------------------------------ - ! - ! cam_grid_dim_names: Return the names of the dimensions of the - ! grid axes. - ! Note that these may be the same - ! - !------------------------------------------------------------------------ - subroutine cam_grid_dim_names(this, name1, name2) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - call this%lon_coord%get_dim_name(name1) - call this%lat_coord%get_dim_name(name2) - - end subroutine cam_grid_dim_names - - !------------------------------------------------------------------------ - ! - ! cam_grid_dimensions_id: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !------------------------------------------------------------------------ - subroutine cam_grid_dimensions_id(gridid, dims, rank) - ! Dummy arguments - integer, intent(in) :: gridid - integer, intent(inout) :: dims(2) - integer, optional, intent(out) :: rank - - ! Local variables - integer :: index - character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg - - index = get_cam_grid_index(gridid) - if (index < 0) then - write(errormsg, *) 'No CAM grid with ID =', gridid - call endrun(errormsg) + ! We are done with this variable descriptor, reset for next file + deallocate(this%vardesc(file_index_loc)%p) + nullify(this%vardesc(file_index_loc)%p) + ! Same with the bounds descriptor + if (associated(this%bndsvdesc(file_index_loc)%p)) then + deallocate(this%bndsvdesc(file_index_loc)%p) + nullify(this%bndsvdesc(file_index_loc)%p) + end if + end if ! Do we write the variable? + + end subroutine write_horiz_coord_var + +!!####################################################################### +!! +!! CAM grid functions +!! +!!####################################################################### + + integer function get_cam_grid_index_char(gridname) + ! Dummy arguments + character(len=*), intent(in) :: gridname + ! Local variables + integer :: i + + get_cam_grid_index_char = -1 + do i = 1, registeredhgrids + if(trim(gridname) == trim(cam_grids(i)%name)) then + get_cam_grid_index_char = i + exit + end if + end do + + end function get_cam_grid_index_char + + integer function get_cam_grid_index_int(gridid) + ! Dummy arguments + integer, intent(in) :: gridid + ! Local variables + integer :: i + + get_cam_grid_index_int = -1 + do i = 1, registeredhgrids + if(gridid == cam_grids(i)%id) then + get_cam_grid_index_int = i + exit + end if + end do + + end function get_cam_grid_index_int + + subroutine find_cam_grid_attr(gridind, name, attr) + ! Dummy arguments + integer, intent(in) :: gridind + character(len=*), intent(in) :: name + class(cam_grid_attribute_t), pointer, intent(out) :: attr + ! Local variable + type(cam_grid_attr_ptr_t), pointer :: attrPtr + + nullify(attr) + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) +!!XXgoldyXX: Is this not working in PGI? +! attr => attrPtr%getAttr() + attr => attrPtr%attr + if (trim(name) == trim(attr%name)) then + exit else - call cam_grids(index)%coord_lengths(dims) - end if - if (present(rank)) then - call cam_grids(index)%dim_names(dname1, dname2) - if (trim(dname1) == trim(dname2)) then - rank = 1 - else - rank = 2 - end if - end if - - end subroutine cam_grid_dimensions_id - - !------------------------------------------------------------------------ - ! - ! cam_grid_dimensions_name: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !------------------------------------------------------------------------ - subroutine cam_grid_dimensions_name(gridname, dims, rank) - ! Dummy arguments - character(len=*), intent(in) :: gridname - integer, intent(inout) :: dims(2) - integer, optional, intent(out) :: rank - - ! Local variables - integer :: gridind - character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind < 0) then - write(errormsg, *) 'No CAM grid with name = ', trim(gridname) - call endrun(errormsg) +!!XXgoldyXX: Is this not working in PGI? +! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + nullify(attr) + end if + end do + return ! attr should be NULL if not found + end subroutine find_cam_grid_attr + + logical function cam_grid_attr_exists(gridname, name) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + ! Local variables + class(cam_grid_attribute_t), pointer :: attr + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, name, attr) + cam_grid_attr_exists = associated(attr) + nullify(attr) + else + call endrun('cam_grid_attr_exists: Bad grid name, "'//trim(gridname)//'"') + end if + end function cam_grid_attr_exists + + integer function num_cam_grid_attrs(gridind) + ! Dummy arguments + integer, intent(in) :: gridind + + ! Local variables + class(cam_grid_attr_ptr_t), pointer :: attrPtr + + num_cam_grid_attrs = 0 + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) + num_cam_grid_attrs = num_cam_grid_attrs + 1 +!!XXgoldyXX: Is this not working in PGI? +! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + end function num_cam_grid_attrs + + subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & + unstruct, block_indexed, zonal_grid, src_in, dest_in) + ! Dummy arguments + character(len=*), intent(in) :: name + integer, intent(in) :: id + type(horiz_coord_t), pointer, intent(in) :: lat_coord + type(horiz_coord_t), pointer, intent(in) :: lon_coord + integer(iMap), pointer, intent(in) :: map(:,:) + logical, optional, intent(in) :: unstruct + logical, optional, intent(in) :: block_indexed + logical, optional, intent(in) :: zonal_grid + integer, optional, intent(in) :: src_in(2) + integer, optional, intent(in) :: dest_in(2) + + ! Local variables + character(len=max_hcoordname_len) :: latdimname, londimname + character(len=120) :: errormsg + integer :: i + integer :: src(2), dest(2) + character(len=*), parameter :: subname = 'CAM_GRID_REGISTER' + + ! For a values grid, we do not allow multiple calls + if (get_cam_grid_index(trim(name)) > 0) then + call endrun(trim(subname)//': Grid, '//trim(name)//', already exists') + else if (get_cam_grid_index(id) > 0) then + i = get_cam_grid_index(id) + write(errormsg, '(4a,i5,3a)') trim(subname), ': Attempt to add grid, ', & + trim(name), ' with id = ', id, ', however, grid ', & + trim(cam_grids(i)%name), ' already has that ID' + call endrun(trim(errormsg)) + else if (registeredhgrids >= maxhgrids) then + call endrun(trim(subname)//": Too many grids") + else + registeredhgrids = registeredhgrids + 1 + cam_grids(registeredhgrids)%name = trim(name) + cam_grids(registeredhgrids)%id = id + ! Quick sanity checks to make sure these aren't mixed up + if (.not. lat_coord%latitude) then + call endrun(subname//': lat_coord is not a latitude coordinate') + end if + if (lon_coord%latitude) then + call endrun(subname//': lon_coord is not a longitude coordinate') + end if + cam_grids(registeredhgrids)%lat_coord => lat_coord + cam_grids(registeredhgrids)%lon_coord => lon_coord + call lat_coord%get_dim_name(latdimname) + call lon_coord%get_dim_name(londimname) + if (present(unstruct)) then + cam_grids(registeredhgrids)%unstructured = unstruct else - call cam_grids(gridind)%coord_lengths(dims) - end if - if (present(rank)) then - call cam_grids(gridind)%dim_names(dname1, dname2) - if (trim(dname1) == trim(dname2)) then - rank = 1 - else - rank = 2 - end if - end if - - end subroutine cam_grid_dimensions_name - - !------------------------------------------------------------------------ - ! - ! cam_grid_set_map: Set a grid's distribution map - ! This maps the local grid elements to global file order - ! - !------------------------------------------------------------------------ - subroutine cam_grid_set_map(this, map, src, dest) - use spmd_utils, only: mpicom - use mpi, only: mpi_sum, mpi_integer - ! Dummy arguments - class(cam_grid_t) :: this - integer(iMap), pointer :: map(:,:) - integer, intent(in) :: src(2) ! decomp info - integer, intent(in) :: dest(2) ! Standard dim(s) in file - - ! Local variables - integer :: dims(2) - integer :: dstrt, dend - integer :: gridlen, gridloc, ierr - - ! Check to make sure the map meets our needs - call this%coord_lengths(dims) - dend = size(map, 1) - ! We always have to have one source and one destination - if (dest(2) > 0) then - dstrt = dend - 1 + if (trim(latdimname) == trim(londimname)) then + cam_grids(registeredhgrids)%unstructured = .true. + else + cam_grids(registeredhgrids)%unstructured = .false. + end if + end if + if (present(block_indexed)) then + cam_grids(registeredhgrids)%block_indexed = block_indexed + else + cam_grids(registeredhgrids)%block_indexed = cam_grids(registeredhgrids)%unstructured + end if + if (present(zonal_grid)) then + ! Check the size of the longitude coordinate + call lon_coord%get_coord_len(i) + if (i /= 1) then + call endrun(subname//': lon_coord is not of size 1 for a zonal grid') + end if + cam_grids(registeredhgrids)%zonal_grid = zonal_grid else - dstrt = dend + cam_grids(registeredhgrids)%zonal_grid = .false. end if - if ((src(2) /= 0) .and. (dstrt < 3)) then - call endrun('cam_grid_set_map: src & dest too large for map') - else if (dstrt < 2) then - call endrun('cam_grid_set_map: dest too large for map') - ! No else needed + if (associated(cam_grids(registeredhgrids)%map)) then + call endrun(trim(subname)//": new grid map should not be associated") end if - if (dstrt == dend) then - gridloc = count(map(dend,:) /= 0) + if (present(src_in)) then + src = src_in else - gridloc = count((map(dstrt,:) /= 0) .and. (map(dend,:) /= 0)) + src(1) = 1 + src(2) = -1 end if - call MPI_Allreduce(gridloc, gridlen, 1, MPI_INTEGER, MPI_SUM, & - mpicom, ierr) - if (gridlen /= product(dims)) then - call endrun('cam_grid_set_map: Bad map size for '//trim(this%name)) + if (present(dest_in)) then + dest = dest_in else - if (.not. associated(this%map)) then - allocate(this%map) - end if - call this%map%init(map, this%unstructured, src, dest) + dest(1) = 1 + if (cam_grids(registeredhgrids)%unstructured) then + dest(2) = 0 + else + dest(2) = 2 + end if + end if + allocate(cam_grids(registeredhgrids)%map) + call cam_grids(registeredhgrids)%map%init(map, & + cam_grids(registeredhgrids)%unstructured, src, dest) + call cam_grids(registeredhgrids)%print_cam_grid() + end if + + end subroutine cam_grid_register + + subroutine print_cam_grid(this) + class(cam_grid_t) :: this + + type(cam_grid_attr_ptr_t), pointer :: attrPtr + class(cam_grid_attribute_t), pointer :: attr + if (masterproc) then + write(iulog, '(3a,i4,4a,3(a,l2))') 'Grid: ', trim(this%name), & + ', ID = ', this%id, & + ', lat coord = ', trim(this%lat_coord%name), & + ', lon coord = ', trim(this%lon_coord%name), & + ', unstruct = ', this%unstructured, & + ', block_ind = ', this%block_indexed, & + ', zonal_grid = ', this%zonal_grid + attrPtr => this%attributes + do while (associated(attrPtr)) +!!XXgoldyXX: Is this not working in PGI? +! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%print_attr() +!!XXgoldyXX: Is this not working in PGI? +! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + end if + end subroutine print_cam_grid + + integer function cam_grid_num_grids() + cam_grid_num_grids = registeredhgrids + end function cam_grid_num_grids + + ! Return .true. iff id represents a valid CAM grid + logical function cam_grid_check(id) + ! Dummy argument + integer, intent(in) :: id + + cam_grid_check = ((get_cam_grid_index(id) > 0) .and. & + (get_cam_grid_index(id) <= cam_grid_num_grids())) + end function cam_grid_check + + integer function cam_grid_id(name) + ! Dummy argument + character(len=*), intent(in) :: name + + ! Local variable + integer :: index + + index = get_cam_grid_index(name) + if (index > 0) then + cam_grid_id = cam_grids(index)%id + else + cam_grid_id = -1 + end if + + end function cam_grid_id + + ! Return the size of a local array for grid, ID. + ! With no optional argument, return the basic 2D array size + ! nlev represents levels or the total column size (product(mdims)) + integer function cam_grid_get_local_size(id, nlev) + + ! Dummy arguments + integer, intent(in) :: id + integer, optional, intent(in) :: nlev + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + cam_grid_get_local_size = cam_grids(gridid)%num_elem() + if (present(nlev)) then + cam_grid_get_local_size = cam_grid_get_local_size * nlev + end if + else + write(errormsg, *) 'cam_grid_get_local_size: Bad grid ID, ', id + call endrun(errormsg) + end if + + end function cam_grid_get_local_size + + ! Given some array information, find the dimension NetCDF IDs on for this grid + subroutine cam_grid_get_file_dimids(id, File, dimids) + use pio, only: file_desc_t + + ! Dummy arguments + integer, intent(in) :: id + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(out) :: dimids(:) + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%find_dimids(File, dimids) + else + write(errormsg, *) 'cam_grid_get_file_dimids: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_get_file_dimids + + ! Given some array information, find or compute a PIO decomposition + subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, iodesc, & + field_dnames, file_dnames) + use pio, only: io_desc_t + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(in) :: field_lens(:) ! Array dim sizes + integer, intent(in) :: file_lens(:) ! File dim sizes + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + character(len=*), optional, intent(in) :: field_dnames(:) + character(len=*), optional, intent(in) :: file_dnames(:) + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%get_decomp(field_lens, file_lens, dtype, iodesc, & + field_dnames, file_dnames) + else + write(errormsg, *) 'cam_grid_get_decomp: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_get_decomp + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_2d_int + ! + ! Interface function for the grid%read_darray_2d_int method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_int(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_2d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_3d_int + ! + ! Interface function for the grid%read_darray_2d_ method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_int(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_3d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_2d_double + ! + ! Interface function for the grid%read_darray_2d_double method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_double(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_2d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_3d_double + ! + ! Interface function for the grid%read_darray_3d_double method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_double(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_3d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_2d_real + ! + ! Interface function for the grid%read_darray_2d_real method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_real(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_2d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_dist_array_3d_real + ! + ! Interface function for the grid%read_darray_3d_real method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_real(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_read_dist_array_3d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_2d_int + ! + ! Interface function for the grid%write_darray_2d_int method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_int(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_2d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_3d_int + ! + ! Interface function for the grid%write_darray_3d_int method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_int(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_3d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_2d_double + ! + ! Interface function for the grid%write_darray_2d_double method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_double(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_2d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_3d_double + ! + ! Interface function for the grid%write_darray_3d_double method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_double(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_3d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_2d_real + ! + ! Interface function for the grid%write_darray_2d_real method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + write(iulog,*) gridid + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_real(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_2d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_3d_real + ! + ! Interface function for the grid%write_darray_3d_real method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_real(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_3d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_real + + subroutine cam_grid_get_gcid(id, gcid) + + ! Dummy arguments + integer, intent(in) :: id + integer(iMap), pointer :: gcid(:) + + ! Local variables + integer :: gridid + integer :: fieldbounds(2,2) + integer :: fieldlens(2) + integer :: filelens(2) + type(cam_filemap_t), pointer :: map + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + map => cam_grids(gridid)%map + call cam_grids(gridid)%coord_lengths(filelens) + call map%array_bounds(fieldbounds) + fieldlens(:) = fieldbounds(:,2) - fieldbounds(:,1) + 1 + call map%get_filemap(fieldlens, filelens, gcid) + else + call endrun('cam_grid_get_gcid: Bad grid ID') + end if + end subroutine cam_grid_get_gcid + + subroutine cam_grid_get_array_bounds(id, dims) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(inout) :: dims(:,:) + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_get_array_bounds: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + call cam_grids(gridid)%map%array_bounds(dims) + end if + else + call endrun('cam_grid_get_array_bounds: Bad grid ID') + end if + + end subroutine cam_grid_get_array_bounds + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_coord_names: Return the names of the grid axes + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_coord_names(id, lon_name, lat_name) + + ! Dummy arguments + integer, intent(in) :: id + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: lat_name + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%coord_names(lon_name, lat_name) + else + call endrun('cam_grid_get_coord_names: Bad grid ID') + end if + + end subroutine cam_grid_get_coord_names + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_dim_names: Return the names of the grid axes dimensions. + ! Note that these may be the same + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_dim_names_id(id, name1, name2) + + ! Dummy arguments + integer, intent(in) :: id + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%dim_names(name1, name2) + else + call endrun('cam_grid_get_dim_names_id: Bad grid ID') + end if + + end subroutine cam_grid_get_dim_names_id + + subroutine cam_grid_get_dim_names_name(gridname, name1, name2) + + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + ! Local variables + integer :: gridind + character(len=120) :: errormsg + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind < 0) then + write(errormsg, *) 'No CAM grid with name = ', trim(gridname) + call endrun('cam_grid_get_dim_names_name: '//errormsg) + else + call cam_grids(gridind)%dim_names(name1, name2) + end if + + end subroutine cam_grid_get_dim_names_name + + logical function cam_grid_has_blocksize(id) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_has_blocksize: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + cam_grid_has_blocksize = cam_grids(gridid)%map%has_blocksize() + end if + else + call endrun('cam_grid_has_blocksize: Bad grid ID') + end if + end function cam_grid_has_blocksize + + ! Return the number of active columns in the block specified by block_id + integer function cam_grid_get_block_count(id, block_id) result(ncol) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(in) :: block_id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_get_block_count: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + ncol = cam_grids(gridid)%map%blocksize(block_id) end if - end subroutine cam_grid_set_map - - !------------------------------------------------------------------------ - ! - ! cam_grid_local_size: return the local size of a 2D array on this grid - ! - !------------------------------------------------------------------------ - integer function cam_grid_local_size(this) + else + call endrun('cam_grid_get_block_count: Bad grid ID') + end if + end function cam_grid_get_block_count - ! Dummy argument - class(cam_grid_t) :: this + function cam_grid_get_latvals(id) result(latvals) - ! Local variable - character(len=128) :: errormsg + ! Dummy argument + integer, intent(in) :: id + real(r8), pointer :: latvals(:) - if (.not. associated(this%map)) then - write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' - call endrun('cam_grid_local_size: '//trim(errormsg)) + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%lat_coord%values)) then + nullify(latvals) else - cam_grid_local_size = this%map%num_elem() + latvals => cam_grids(gridid)%lat_coord%values end if + else + call endrun('cam_grid_get_latvals: Bad grid ID') + end if + end function cam_grid_get_latvals - end function cam_grid_local_size + function cam_grid_get_lonvals(id) result(lonvals) - !------------------------------------------------------------------------ - ! - ! cam_grid_get_lon_lat: Find the latitude and longitude for a given - ! grid map index. Note if point is not mapped - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_lon_lat(this, index, lon, lat, isMapped) + ! Dummy arguments + integer, intent(in) :: id + real(r8), pointer :: lonvals(:) - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(in) :: index - real(r8), intent(out) :: lon - real(r8), intent(out) :: lat - logical, intent(out) :: isMapped - - ! Local variables - integer :: latindex, lonindex - character(len=*), parameter :: subname = "cam_grid_get_lon_lat" - - if (this%block_indexed) then - lonindex = index - latindex = index - isMapped = this%map%is_mapped(index) + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%lon_coord%values)) then + nullify(lonvals) else - call this%map%coord_vals(index, lonindex, latindex, isMapped) - end if - - !!XXgoldyXX: May be able to relax all the checks - if ( (latindex < LBOUND(this%lat_coord%values, 1)) .or. & - (latindex > UBOUND(this%lat_coord%values, 1))) then - call endrun(trim(subname)//": index out of range for latvals") + lonvals => cam_grids(gridid)%lon_coord%values + end if + else + call endrun('cam_grid_get_lonvals: Bad grid ID') + end if + end function cam_grid_get_lonvals + + function cam_grid_get_areawt(id) result(wtvals) + + ! Dummy argument + integer, intent(in) :: id + real(r8), pointer :: wtvals(:) + + ! Local variables + character(len=max_chars) :: wtname + integer :: gridind + class(cam_grid_attribute_t), pointer :: attrptr + character(len=120) :: errormsg + + nullify(attrptr) + gridind = get_cam_grid_index(id) + if (gridind > 0) then + select case(cam_grids(gridind)%name) + case('GLL') + wtname='area_weight_gll' + case('EUL') + wtname='gw' + case('FV') + wtname='gw' + case('INI') + wtname='area_weight_ini' + case('physgrid') + wtname='areawt' + case('FVM') + wtname='area_weight_fvm' + case('mpas_cell') + wtname='area_weight_mpas' + case default + call endrun('cam_grid_get_areawt: Invalid gridname:'//trim(cam_grids(gridind)%name)) + end select + + call find_cam_grid_attr(gridind, trim(wtname), attrptr) + if (.not.associated(attrptr)) then + write(errormsg, '(4a)') & + 'cam_grid_get_areawt: error retrieving weight attribute ', trim(wtname), & + ' for cam grid ', cam_grids(gridind)%name + call endrun(errormsg) + else + call attrptr%print_attr() + select type(attrptr) + type is (cam_grid_attribute_1d_r8_t) + wtvals => attrptr%values + class default + call endrun('cam_grid_get_areawt: wt attribute is not a real datatype') + end select + end if + end if + + end function cam_grid_get_areawt + + ! Find the longitude and latitude of a range of map entries + ! beg and end are the range of the first source index. blk is a block or chunk index + subroutine cam_grid_get_coords(id, beg, end, blk, lon, lat) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(in) :: beg + integer, intent(in) :: end + integer, intent(in) :: blk + real(r8), intent(inout) :: lon(:) + real(r8), intent(inout) :: lat(:) + + ! Local variables + integer :: gridid + integer :: i + gridid = get_cam_grid_index(id) + if (gridid > 0) then + do i = beg, end + if (cam_grids(gridid)%is_unstructured()) then + call endrun('cam_grid_get_coords: Not implemented') + else + call endrun('cam_grid_get_coords: Not implemented') + end if + end do + else + call endrun('cam_grid_get_coords: Bad grid ID') + end if + end subroutine cam_grid_get_coords + + logical function cam_grid_is_unstructured(id) result(unstruct) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + unstruct = cam_grids(gridid)%is_unstructured() + else + call endrun('cam_grid_is_unstructured: Bad grid ID') + end if + end function cam_grid_is_unstructured + + logical function cam_grid_is_block_indexed(id) result(block_indexed) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + block_indexed = cam_grids(gridid)%is_block_indexed() + else + call endrun('s: Bad grid ID') + end if + end function cam_grid_is_block_indexed + + logical function cam_grid_is_zonal(id) result(zonal) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + zonal = cam_grids(gridid)%is_zonal_grid() + else + call endrun('s: Bad grid ID') + end if + end function cam_grid_is_zonal + + ! Compute or update a grid patch mask + subroutine cam_grid_compute_patch(id, patch, lonl, lonu, latl, latu, cco) + + ! Dummy arguments + integer, intent(in) :: id + type(cam_grid_patch_t), intent(inout) :: patch + real(r8), intent(in) :: lonl + real(r8), intent(in) :: lonu + real(r8), intent(in) :: latl + real(r8), intent(in) :: latu + logical, intent(in) :: cco ! Collect columns? + + ! Local variables + integer :: gridid + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%get_patch_mask(lonl, lonu, latl, latu, patch, cco) + else + call endrun('cam_grid_compute_patch: Bad grid ID') + end if + + end subroutine cam_grid_compute_patch + +!!####################################################################### +!! +!! CAM grid attribute functions +!! +!!####################################################################### + + subroutine cam_grid_attr_init(this, name, long_name, next) + ! Dummy arguments + class(cam_grid_attribute_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + class(cam_grid_attribute_t), pointer :: next + + this%name = trim(name) + this%long_name = trim(long_name) + this%next => next + end subroutine cam_grid_attr_init + + subroutine print_attr_base(this) + ! Dummy arguments + class(cam_grid_attribute_t), intent(in) :: this + if (masterproc) then + write(iulog, '(5a)') 'Attribute: ', trim(this%name), ", long name = '", & + trim(this%long_name), "'" + end if + end subroutine print_attr_base + + subroutine cam_grid_attr_init_0d_int(this, name, long_name, val) + ! Dummy arguments + class(cam_grid_attribute_0d_int_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + integer, intent(in) :: val + +! call this%cam_grid_attr_init(name, '') + this%name = trim(name) + this%long_name = trim(long_name) + this%ival = val + end subroutine cam_grid_attr_init_0d_int + + subroutine print_attr_0d_int(this) + ! Dummy arguments + class(cam_grid_attribute_0d_int_t), intent(in) :: this + + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' value = ', this%ival + end if + end subroutine print_attr_0d_int + + subroutine cam_grid_attr_init_0d_char(this, name, long_name, val) + ! Dummy arguments + class(cam_grid_attribute_0d_char_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: val + +! call this%cam_grid_attr_init(name, '') + this%name = trim(name) + this%long_name = trim(long_name) + this%val = trim(val) + end subroutine cam_grid_attr_init_0d_char + + subroutine print_attr_0d_char(this) + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(in) :: this + + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' value = ', trim(this%val) + end if + end subroutine print_attr_0d_char + + subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & + dimsize, values, map) + ! Dummy arguments + class(cam_grid_attribute_1d_int_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + integer, target, intent(in) :: values(:) + integer(iMap), optional, target, intent(in) :: map(:) + +! call this%cam_grid_attr_init(trim(name), trim(long_name)) + if (len_trim(name) > max_hcoordname_len) then + call endrun('cam_grid_attr_1d_int: name too long') + end if + this%name = trim(name) + if (len_trim(long_name) > max_chars) then + call endrun('cam_grid_attr_1d_int: long_name too long') + end if + this%long_name = trim(long_name) + + if (len_trim(dimname) > max_hcoordname_len) then + call endrun('cam_grid_attr_1d_int: dimname too long') + end if + this%dimname = trim(dimname) + this%dimsize = dimsize + this%values => values + ! Fill in the optional map + if (present(map)) then + allocate(this%map(size(map))) + this%map(:) = map(:) + else + nullify(this%map) + end if + end subroutine cam_grid_attr_init_1d_int + + subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & + dimsize, values, map) + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + real(r8), target, intent(in) :: values(:) + integer(iMap), optional, target, intent(in) :: map(:) + +! call this%cam_grid_attr_init(trim(name), trim(long_name), next) + this%name = trim(name) + this%long_name = trim(long_name) + + this%dimname = trim(dimname) + this%dimsize = dimsize + this%values => values + ! Fill in the optional map + if (present(map)) then + allocate(this%map(size(map))) + this%map(:) = map(:) + else + nullify(this%map) + end if + end subroutine cam_grid_attr_init_1d_r8 + + subroutine print_attr_1d_int(this) + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(in) :: this + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' dimname = ', trim(this%dimname) + end if + end subroutine print_attr_1d_int + + subroutine print_attr_1d_r8(this) + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(in) :: this + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' dimname = ', trim(this%dimname) + end if + end subroutine print_attr_1d_r8 + + subroutine insert_grid_attribute(gridind, attr) + integer, intent(in) :: gridind + class(cam_grid_attribute_t), pointer :: attr + + ! Push a new attribute onto the grid + type(cam_grid_attr_ptr_t), pointer :: attrPtr + + allocate(attrPtr) + call attrPtr%initialize(attr) + call attrPtr%setNext(cam_grids(gridind)%attributes) + cam_grids(gridind)%attributes => attrPtr + call attrPtr%attr%print_attr() + end subroutine insert_grid_attribute + + subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + integer, intent(in) :: val + + ! Local variables + type(cam_grid_attribute_0d_int_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_0d_int: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) else - lat = this%lat_coord%values(latindex) - end if - - if ( (lonindex < LBOUND(this%lon_coord%values, 1)) .or. & - (lonindex > UBOUND(this%lon_coord%values, 1))) then - call endrun(trim(subname)//": index out of range for lonvals") + ! Need a new attribute. + allocate(attr) + call attr%cam_grid_attr_init_0d_int(trim(name), trim(long_name), val) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_int: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if +! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_0d_int + + subroutine add_cam_grid_attribute_0d_char(gridname, name, val) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: val + + ! Local variables + type(cam_grid_attribute_0d_char_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_0d_char: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) else - lon = this%lon_coord%values(lonindex) - end if - - end subroutine cam_grid_get_lon_lat - - !------------------------------------------------------------------------ - ! - ! cam_grid_find_src_dims: Find the correct src array dims for this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_find_src_dims(this, field_dnames, src_out) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(in) :: field_dnames(:) - integer, pointer :: src_out(:) - - ! Local variables - integer :: i, j - integer :: num_coords - character(len=max_hcoordname_len) :: coord_dimnames(2) - - call this%dim_names(coord_dimnames(1), coord_dimnames(2)) - if (associated(src_out)) then - deallocate(src_out) - nullify(src_out) - end if - if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then - num_coords = 1 + ! Need a new attribute. + allocate(attr) + call attr%cam_grid_attr_init_0d_char(trim(name), '', val) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_char: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if +! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_0d_char + + subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & + dimname, values, map) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in), target :: values(:) + integer(iMap), intent(in), target, optional :: map(:) + + ! Local variables + type(cam_grid_attribute_1d_int_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + integer :: dimsize + + nullify(attr) + nullify(attptr) + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_1d_int: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) else - num_coords = 2 - end if - allocate(src_out(2)) ! Currently, all cases have two source dims - do i = 1, num_coords - do j = 1, size(field_dnames) - if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then - src_out(i) = j - end if - end do - end do - if (num_coords < 2) then - src_out(2) = -1 ! Assume a block structure for unstructured grids + ! Need a new attribute. + dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) + if (dimsize < 1) then + dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) + end if + if (dimsize < 1) then + write(errormsg, *) 'add_cam_grid_attribute_1d_int: attribute ', & + 'dimension ', trim(dimname), ' for ', trim(name), ', not found' + call endrun(errormsg) + end if + allocate(attr) + call attr%cam_grid_attr_init_1d_int(trim(name), trim(long_name), & + trim(dimname), dimsize, values, map) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_int: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if +! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_1d_int + + subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & + dimname, values, map) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + real(r8), intent(in), target :: values(:) + integer(iMap), intent(in), target, optional :: map(:) + + ! Local variables + type(cam_grid_attribute_1d_r8_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + integer :: dimsize + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_1d_r8: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) + else + ! Need a new attribute. + dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) + if (dimsize < 1) then + dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) + end if + if (dimsize < 1) then + write(errormsg, *) 'add_cam_grid_attribute_1d_r8: attribute ', & + 'dimension ', trim(dimname), ' for ', trim(name), ', not found' + call endrun(errormsg) + end if + allocate(attr) + call attr%cam_grid_attr_init_1d_r8(trim(name), trim(long_name), & + trim(dimname), dimsize, values, map) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_r8: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if +! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_1d_r8 + +!!####################################################################### +!! +!! CAM grid attribute pointer (list node) functions +!! +!!####################################################################### + + subroutine initializeAttrPtr(this, attr) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + class(cam_grid_attribute_t), target :: attr + + if (associated(this%next)) then + if (masterproc) then + write(iulog, *) 'WARNING: Overwriting attr pointer for cam_grid_attr_ptr_t' end if + end if + this%attr => attr + end subroutine initializeAttrPtr - end subroutine cam_grid_find_src_dims + function getAttrPtrAttr(this) + ! Dummy variable + class(cam_grid_attr_ptr_t) :: this + class(cam_grid_attribute_t), pointer :: getAttrPtrAttr - !------------------------------------------------------------------------ - ! - ! cam_grid_find_dest_dims: Find the correct file array dims for this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(in) :: file_dnames(:) - integer, pointer :: dest_out(:) - - ! Local variables - integer :: i, j - integer :: num_coords - character(len=max_hcoordname_len) :: coord_dimnames(2) - - call this%dim_names(coord_dimnames(1), coord_dimnames(2)) - if (associated(dest_out)) then - deallocate(dest_out) - nullify(dest_out) - end if - if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then - num_coords = 1 - else - num_coords = 2 - end if - allocate(dest_out(num_coords)) - dest_out = 0 - do i = 1, num_coords - do j = 1, size(file_dnames) - if (trim(file_dnames(j)) == trim(coord_dimnames(i))) then - dest_out(i) = j - end if - end do - end do + getAttrPtrAttr => this%attr + end function getAttrPtrAttr - end subroutine cam_grid_find_dest_dims + function getAttrPtrNext(this) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + type(cam_grid_attr_ptr_t), pointer :: getAttrPtrNext - !------------------------------------------------------------------------ - ! - ! cam_grid_get_pio_decomp: Find or create a PIO decomp on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & - iodesc, field_dnames, file_dnames) - use pio, only: io_desc_t - use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation + getAttrPtrNext => this%next + end function getAttrPtrNext - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(in) :: field_lens(:) - integer, intent(in) :: file_lens(:) - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - character(len=*), optional, intent(in) :: field_dnames(:) - character(len=*), optional, intent(in) :: file_dnames(:) - - ! Local variables - integer, pointer :: src_in(:) - integer, pointer :: dest_in(:) - integer, allocatable :: permutation(:) - logical :: is_perm - character(len=128) :: errormsg + subroutine setAttrPtrNext(this, next) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + type(cam_grid_attr_ptr_t), pointer :: next - nullify(src_in) - nullify(dest_in) - is_perm = .false. - if (.not. associated(this%map)) then - write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' - call endrun('cam_grid_get_pio_decomp: '//trim(errormsg)) + if (associated(this%next)) then + if (masterproc) then + write(iulog, *) 'WARNING: Overwriting next pointer for cam_grid_attr_ptr_t' + end if + end if + this%next => next + end subroutine setAttrPtrNext + + !--------------------------------------------------------------------------- + ! + ! write_cam_grid_attr_0d_int + ! + ! Write a grid attribute + ! + !--------------------------------------------------------------------------- + + subroutine write_cam_grid_attr_0d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, & + pio_inq_att, PIO_GLOBAL + use cam_pio_utils, only: cam_pio_def_var + + ! Dummy arguments + class(cam_grid_attribute_0d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: attrtype + integer(imap) :: attrlen + integer :: ierr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + if (len_trim(attr%long_name) > 0) then + ! This 0d attribute is a scalar variable with a long_name attribute + ! First, define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_int, attr%vardesc(file_index_loc)%p, & + existOK=.false.) + ierr=pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_0d_int') else - if (present(field_dnames)) then - call this%find_src_dims(field_dnames, src_in) - end if - if (present(file_dnames)) then - call this%find_dest_dims(file_dnames, dest_in) - end if - if (present(file_dnames) .and. present(field_dnames)) then - ! This only works if the arrays are the same size - if (size(file_dnames) == size(field_dnames)) then - allocate(permutation(size(file_dnames))) - call calc_permutation(file_dnames, field_dnames, & - permutation, is_perm) - end if - end if - ! Call cam_pio_get_decomp with the appropriate options - if (present(field_dnames) .and. present(file_dnames)) then - if (is_perm) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, & - dtype, this%map, field_dist_in=src_in, & - file_dist_in=dest_in, permute=permutation) - else - call cam_pio_get_decomp(iodesc, field_lens, file_lens, & - dtype, this%map, field_dist_in=src_in, & - file_dist_in=dest_in) - end if - else if (present(field_dnames)) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, field_dist_in=src_in) - else if (present(file_dnames)) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, file_dist_in=dest_in) - else - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map) - end if - end if - if (associated(src_in)) then - deallocate(src_in) - nullify(src_in) - end if - if (associated(dest_in)) then - deallocate(dest_in) - nullify(dest_in) - end if - if (allocated(permutation)) then - deallocate(permutation) + ! This 0d attribute is a global attribute + ! Check to see if the attribute already exists in the file + ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) + if (ierr /= PIO_NOERR) then + ! Time to define the attribute + ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%ival) + call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_int') + end if + end if + end if + + end subroutine write_cam_grid_attr_0d_int + + !--------------------------------------------------------------------------- + ! + ! write_cam_grid_attr_0d_char + ! + ! Write a grid attribute + ! + !--------------------------------------------------------------------------- + + subroutine write_cam_grid_attr_0d_char(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, & + pio_inq_att, PIO_GLOBAL + + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: attrtype + integer(imap) :: attrlen + integer :: ierr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! The 0d char attributes are global attribues + ! Check to see if the attribute already exists in the file + ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) + if (ierr /= PIO_NOERR) then + ! Time to define the variable + ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%val) + call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_char') + end if + end if + + end subroutine write_cam_grid_attr_0d_char + + !--------------------------------------------------------------------------- + ! + ! write_cam_grid_attr_1d_int + ! + ! Write a grid attribute + ! + !--------------------------------------------------------------------------- + + subroutine write_cam_grid_attr_1d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr + use pio, only: pio_inq_dimid, pio_int + use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile + + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: dimid ! PIO dimension ID + character(len=120) :: errormsg + integer :: ierr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! Check to see if the dimension already exists in the file + ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) + if (ierr /= PIO_NOERR) then + ! The dimension has not yet been defined. This is an error + ! NB: It should have been defined as part of a coordinate + write(errormsg, *) 'write_cam_grid_attr_1d_int: dimension, ', & + trim(attr%dimname), ', does not exist' + call cam_pio_closefile(File) + call endrun(errormsg) + end if + ! Time to define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), & + attr%vardesc(file_index_loc)%p, existOK=.false.) + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_int') + end if + + end subroutine write_cam_grid_attr_1d_int + + !--------------------------------------------------------------------------- + ! + ! write_cam_grid_attr_1d_r8 + ! + ! Write a grid attribute + ! + !--------------------------------------------------------------------------- + + subroutine write_cam_grid_attr_1d_r8(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double, & + pio_inq_dimid + use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile + + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: dimid ! PIO dimension ID + character(len=120) :: errormsg + integer :: ierr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! Check to see if the dimension already exists in the file + ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) + if (ierr /= PIO_NOERR) then + ! The dimension has not yet been defined. This is an error + ! NB: It should have been defined as part of a coordinate + write(errormsg, *) 'write_cam_grid_attr_1d_r8: dimension, ', & + trim(attr%dimname), ', does not exist' + call cam_pio_closefile(File) + call endrun(errormsg) + end if + ! Time to define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_double, (/dimid/), & + attr%vardesc(file_index_loc)%p, existOK=.false.) + ! long_name + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_r8') + end if + + end subroutine write_cam_grid_attr_1d_r8 + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_copy + ! + ! Copy an attribute from a source grid to a destination grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name) + ! Dummy arguments + character(len=*), intent(in) :: src_grid + character(len=*), intent(in) :: dest_grid + character(len=*), intent(in) :: attribute_name + + ! Local variables + character(len=120) :: errormsg + integer :: src_ind, dest_ind + class(cam_grid_attribute_t), pointer :: attr + + ! Find the source and destination grid indices + src_ind = get_cam_grid_index(trim(src_grid)) + dest_ind = get_cam_grid_index(trim(dest_grid)) + + call find_cam_grid_attr(dest_ind, trim(attribute_name), attr) + if (associated(attr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') 'CAM_GRID_ATTRIBUTE_COPY: attribute ', & + trim(attribute_name),' already exists for ',cam_grids(dest_ind)%name + call endrun(errormsg) + else + call find_cam_grid_attr(src_ind, trim(attribute_name), attr) + if (associated(attr)) then + ! Copy the attribute + call insert_grid_attribute(dest_ind, attr) + else + write(errormsg, '(4a)') ": Did not find attribute, '", & + trim(attribute_name), "' in ", cam_grids(src_ind)%name + call endrun("CAM_GRID_ATTRIBUTE_COPY"//errormsg) + end if + end if + + end subroutine cam_grid_attribute_copy + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_attr + ! + ! Write the dimension and coordinate attributes for the horizontal history + ! coordinates. + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_attr(File, grid_id, header_info, file_index) + use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: grid_id + type(cam_grid_header_info_t), intent(inout) :: header_info + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: gridind + class(cam_grid_attribute_t), pointer :: attr + type(cam_grid_attr_ptr_t), pointer :: attrPtr + integer :: dimids(2) + integer :: err_handling + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + gridind = get_cam_grid_index(grid_id) + !! Fill this in to make sure history finds grid + header_info%grid_id = grid_id + + if (allocated(header_info%hdims)) then + deallocate(header_info%hdims) + end if + + if (associated(header_info%lon_varid)) then + ! This could be a sign of bad memory management + call endrun('CAM_GRID_WRITE_ATTR: lon_varid should be NULL') + end if + if (associated(header_info%lat_varid)) then + ! This could be a sign of bad memory management + call endrun('CAM_GRID_WRITE_ATTR: lat_varid should be NULL') + end if + + ! Only write this grid if not already defined + if (cam_grids(gridind)%attrs_defined(file_index_loc)) then + ! We need to fill out the hdims info for this grid + call cam_grids(gridind)%find_dimids(File, dimids) + if (dimids(2) < 0) then + allocate(header_info%hdims(1)) + header_info%hdims(1) = dimids(1) + else + allocate(header_info%hdims(2)) + header_info%hdims(1:2) = dimids(1:2) end if + else + ! Write the horizontal coord attributes first so that we have the dims + call cam_grids(gridind)%lat_coord%write_attr(File, dimids(2), file_index=file_index_loc) + call cam_grids(gridind)%lon_coord%write_attr(File, dimids(1), file_index=file_index_loc) - end subroutine cam_grid_get_pio_decomp - - !------------------------------------------------------------------------ - ! - ! cam_grid_find_dimids: Find the dimension NetCDF IDs on for - ! this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_find_dimids(this, File, dimids) - use pio, only: file_desc_t, pio_noerr, pio_inq_dimid - use pio, only: pio_seterrorhandling, pio_bcast_error - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(out) :: dimids(:) - - ! Local vaariables - integer :: ierr - integer :: err_handling - character(len=max_hcoordname_len) :: dimname1, dimname2 - character(len=*), parameter :: subname = 'CAM_GRID_FIND_DIMIDS' + if (dimids(2) == dimids(1)) then + allocate(header_info%hdims(1)) + else + allocate(header_info%hdims(2)) + header_info%hdims(2) = dimids(2) + end if + header_info%hdims(1) = dimids(1) ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) + call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) - call this%dim_names(dimname1, dimname2) - if (size(dimids) < 1) then - call endrun(subname//': dimids must have positive size') - end if - dimids = -1 - ! Check the first dimension - ierr = pio_inq_dimid(File, trim(dimname1), dimids(1)) - if(ierr /= PIO_NOERR) then - call endrun(subname//': '//trim(this%name)//' dimension, '//trim(dimname1)//', does not exist on file') - end if - if (trim(dimname1) /= trim(dimname2)) then - ! Structured grid, find second dimid - if (size(dimids) < 2) then - call endrun(subname//': dimids too small for '//trim(this%name)) - end if - ierr = pio_inq_dimid(File, trim(dimname2), dimids(2)) - if(ierr /= PIO_NOERR) then - call endrun(subname//': '//trim(this%name)//' dimension, '//trim(dimname2)//', does not exist on file') - end if - end if + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) +!!XXgoldyXX: Is this not working in PGI? +! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%write_attr(File, file_index=file_index_loc) +!!XXgoldyXX: Is this not working in PGI? +! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do - ! Back to whatever error handling was running before this routine + ! Back to previous I/O error handling call pio_seterrorhandling(File, err_handling) + cam_grids(gridind)%attrs_defined(file_index_loc) = .true. + end if + + end subroutine cam_grid_write_attr + + subroutine write_cam_grid_val_0d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_var + + ! Dummy arguments + class(cam_grid_attribute_0d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: ierr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! We only write this var if it is a variable + if (associated(attr%vardesc(file_index_loc)%p)) then + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%ival) + call cam_pio_handle_error(ierr, 'Error writing value in write_cam_grid_val_0d_int') + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) + end if + + end subroutine write_cam_grid_val_0d_int + + subroutine write_cam_grid_val_0d_char(attr, File, file_index) + use pio, only: file_desc_t + + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! This subroutine is a stub because global attributes are written + ! in define mode + return + end subroutine write_cam_grid_val_0d_char + + subroutine write_cam_grid_val_1d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_var, pio_int, & + pio_write_darray, io_desc_t, pio_freedecomp + use cam_pio_utils, only: cam_pio_newdecomp + + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: ierr + type(io_desc_t), pointer :: iodesc + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + nullify(iodesc) + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is not associated, another grid write the values + if (associated(attr%vardesc(file_index_loc)%p)) then + ! Write out the values for this dimension variable + if (associated(attr%map)) then + ! This is a distributed variable, use pio_write_darray + allocate(iodesc) + call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_int) + call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr) + call pio_freedecomp(File, iodesc) + deallocate(iodesc) + nullify(iodesc) + else + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values) + end if + call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_int') + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) + end if + + end subroutine write_cam_grid_val_1d_int + + subroutine write_cam_grid_val_1d_r8(attr, File, file_index) + use pio, only: file_desc_t, pio_put_var, pio_double, & + pio_write_darray, io_desc_t, pio_freedecomp + use cam_pio_utils, only: cam_pio_newdecomp + + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: ierr + type(io_desc_t), pointer :: iodesc + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + nullify(iodesc) + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is not associated, another grid write the values + if (associated(attr%vardesc(file_index_loc)%p)) then + ! Write out the values for this dimension variable + if (associated(attr%map)) then + ! This is a distributed variable, use pio_write_darray + allocate(iodesc) + call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_double) + call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr) + call pio_freedecomp(File, iodesc) + deallocate(iodesc) + nullify(iodesc) + else + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values) + end if + call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_r8') + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) + end if + + end subroutine write_cam_grid_val_1d_r8 + + subroutine cam_grid_write_var(File, grid_id, file_index) + use pio, only: file_desc_t, pio_bcast_error, pio_seterrorhandling + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: grid_id + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: gridind + integer :: err_handling + class(cam_grid_attribute_t), pointer :: attr + type(cam_grid_attr_ptr_t), pointer :: attrPtr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + gridind = get_cam_grid_index(grid_id) + ! Only write if not already done + if (cam_grids(gridind)%attrs_defined(file_index_loc)) then + ! Write the horizontal coorinate values + call cam_grids(gridind)%lon_coord%write_var(File, file_index) + call cam_grids(gridind)%lat_coord%write_var(File, file_index) - end subroutine cam_grid_find_dimids - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_2d_int: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_2d_int(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_read_darray_2d_int' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error reading variable') - end subroutine cam_grid_read_darray_2d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_3d_int: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_3d_int(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_read_darray_3d_int' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error reading variable') - end subroutine cam_grid_read_darray_3d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_2d_double: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_2d_double(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: sbnm = 'cam_grid_read_darray_2d_double' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, sbnm//': Error reading variable') - end subroutine cam_grid_read_darray_2d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_3d_double: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: sbnm = 'cam_grid_read_darray_3d_double' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, sbnm//': Error reading variable') - end subroutine cam_grid_read_darray_3d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_2d_real: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_2d_real(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_read_darray_2d_real' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error reading variable') - end subroutine cam_grid_read_darray_2d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_read_darray_3d_real: Read a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_read_darray_3d_real(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_read_darray_3d_real' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error reading variable') - end subroutine cam_grid_read_darray_3d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_2d_int: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_INT - - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_write_darray_2d_int' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing variable') - end subroutine cam_grid_write_darray_2d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_3d_int: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_write_darray_3d_int' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing variable') - end subroutine cam_grid_write_darray_3d_int - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_2d_double: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_write_darray_2d_double' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing variable') - end subroutine cam_grid_write_darray_2d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_3d_double: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subname = 'cam_grid_write_darray_3d_double' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing variable') - - end subroutine cam_grid_write_darray_3d_double - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_2d_real: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subnam = 'cam_grid_write_darray_2d_real' - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subnam//': Error writing variable') - end subroutine cam_grid_write_darray_2d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_write_darray_3d_real: Write a variable defined on this grid - ! - !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, & - hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - character(len=*), parameter :: subnam = 'cam_grid_write_darray_3d_real' - - nullify(iodesc) - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, subnam//': Error writing variable') - end subroutine cam_grid_write_darray_3d_real - - !------------------------------------------------------------------------ - ! - ! cam_grid_get_patch_mask: Compute a map which is defined for locations - ! within the input patch. - ! - !------------------------------------------------------------------------ - subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco) - use spmd_utils, only: mpicom - use mpi, only: mpi_min, mpi_max, mpi_real8 - use shr_const_mod, only: pi=>shr_const_pi + ! Write out the variable values for each grid attribute + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) +!!XXgoldyXX: Is this not working in PGI? +! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%write_val(File, file_index=file_index_loc) +!!XXgoldyXX: Is this not working in PGI? +! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do - ! Dummy arguments - class(cam_grid_t) :: this - real(r8), intent(in) :: lonl, lonu ! Longitude bounds - real(r8), intent(in) :: latl, latu ! Latitude bounds - type(cam_grid_patch_t), intent(inout) :: patch - logical, intent(in) :: cco ! Collect columns? - - ! Local arguments - real(r8) :: mindist, minlondist - real(r8) :: dist, temp1, temp2 ! Test distance calc - real(r8) :: londeg, latdeg - real(r8) :: lon, lat - real(r8) :: londeg_min, latdeg_min - real(r8) :: lonmin, lonmax, latmin, latmax - integer :: minind ! Location of closest point - integer :: mapind ! Grid map index - integer :: latind, lonind - integer :: ierr ! For MPI calls - integer :: dims(2) ! Global dim sizes - integer :: gridloc ! local size of grid - logical :: unstructured ! grid type - logical :: findClosest ! .false. == patch output - logical :: isMapped ! .true. iff point in map - - real(r8), parameter :: maxangle = pi / 4.0_r8 - real(r8), parameter :: deg2rad = pi / 180.0_r8 - real(r8), parameter :: maxtol = 0.99999_r8 ! max cos value - real(r8), parameter :: maxlat = pi * maxtol / 2.0_r8 - character(len=*), parameter :: subname = 'cam_grid_get_patch_mask' + ! Back to previous I/O error handling + call pio_seterrorhandling(File, err_handling) + cam_grids(gridind)%attrs_defined(file_index_loc) = .false. + end if + + end subroutine cam_grid_write_var + + logical function cam_grid_block_indexed(this) + class(cam_grid_t) :: this + + cam_grid_block_indexed = this%block_indexed + end function cam_grid_block_indexed + + logical function cam_grid_zonal_grid(this) + class(cam_grid_t) :: this + + cam_grid_zonal_grid = this%zonal_grid + end function cam_grid_zonal_grid + + logical function cam_grid_unstructured(this) + class(cam_grid_t) :: this + + cam_grid_unstructured = this%unstructured + end function cam_grid_unstructured + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_dims: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_dims(this, dims) + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(inout) :: dims(2) + + if (this%is_unstructured()) then + call this%lon_coord%get_coord_len(dims(1)) + dims(2) = 1 + else + call this%lon_coord%get_coord_len(dims(1)) + call this%lat_coord%get_coord_len(dims(2)) + end if + + end subroutine cam_grid_get_dims + + !--------------------------------------------------------------------------- + ! + ! cam_grid_coord_names: Return the names of the grid axes + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_coord_names(this, lon_name, lat_name) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: lat_name + + call this%lon_coord%get_coord_name(lon_name) + call this%lat_coord%get_coord_name(lat_name) + + end subroutine cam_grid_coord_names + + !--------------------------------------------------------------------------- + ! + ! cam_grid_dim_names: Return the names of the dimensions of the grid axes. + ! Note that these may be the same + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_dim_names(this, name1, name2) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + call this%lon_coord%get_dim_name(name1) + call this%lat_coord%get_dim_name(name2) + + end subroutine cam_grid_dim_names + + !--------------------------------------------------------------------------- + ! + ! cam_grid_dimensions_id: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_dimensions_id(gridid, dims, rank) + ! Dummy arguments + integer, intent(in) :: gridid + integer, intent(inout) :: dims(2) + integer, optional, intent(out) :: rank + + ! Local variables + integer :: index + character(len=max_hcoordname_len) :: dname1, dname2 + character(len=120) :: errormsg + + index = get_cam_grid_index(gridid) + if (index < 0) then + write(errormsg, *) 'No CAM grid with ID =', gridid + call endrun(errormsg) + else + call cam_grids(index)%coord_lengths(dims) + end if + if (present(rank)) then + call cam_grids(index)%dim_names(dname1, dname2) + if (trim(dname1) == trim(dname2)) then + rank = 1 + else + rank = 2 + end if + end if + + end subroutine cam_grid_dimensions_id + + !--------------------------------------------------------------------------- + ! + ! cam_grid_dimensions_name: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_dimensions_name(gridname, dims, rank) + ! Dummy arguments + character(len=*), intent(in) :: gridname + integer, intent(inout) :: dims(2) + integer, optional, intent(out) :: rank + + ! Local variables + integer :: gridind + character(len=max_hcoordname_len) :: dname1, dname2 + character(len=120) :: errormsg + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind < 0) then + write(errormsg, *) 'No CAM grid with name = ', trim(gridname) + call endrun(errormsg) + else + call cam_grids(gridind)%coord_lengths(dims) + end if + if (present(rank)) then + call cam_grids(gridind)%dim_names(dname1, dname2) + if (trim(dname1) == trim(dname2)) then + rank = 1 + else + rank = 2 + end if + end if + + end subroutine cam_grid_dimensions_name + + !--------------------------------------------------------------------------- + ! + ! cam_grid_set_map: Set a grid's distribution map + ! This maps the local grid elements to global file order + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_set_map(this, map, src, dest) + use mpi, only: mpi_sum, mpi_integer + use spmd_utils, only: mpicom + ! Dummy arguments + class(cam_grid_t) :: this + integer(iMap), pointer :: map(:,:) + integer, intent(in) :: src(2) ! decomp info + integer, intent(in) :: dest(2) ! Standard dim(s) in file + + ! Local variables + integer :: dims(2) + integer :: dstrt, dend + integer :: gridlen, gridloc, ierr + + ! Check to make sure the map meets our needs + call this%coord_lengths(dims) + dend = size(map, 1) + ! We always have to have one source and one destination + if (dest(2) > 0) then + dstrt = dend - 1 + else + dstrt = dend + end if + if ((src(2) /= 0) .and. (dstrt < 3)) then + call endrun('cam_grid_set_map: src & dest too large for map') + else if (dstrt < 2) then + call endrun('cam_grid_set_map: dest too large for map') + ! No else needed + end if + if (dstrt == dend) then + gridloc = count(map(dend,:) /= 0) + else + gridloc = count((map(dstrt,:) /= 0) .and. (map(dend,:) /= 0)) + end if + call MPI_Allreduce(gridloc, gridlen, 1, MPI_INTEGER, MPI_SUM, mpicom, ierr) + if (gridlen /= product(dims)) then + call endrun('cam_grid_set_map: Bad map size for '//trim(this%name)) + else if (.not. associated(this%map)) then - call endrun(subname//': Grid, '//trim(this%name)//', has no map') + allocate(this%map) + end if + call this%map%init(map, this%unstructured, src, dest) + end if + end subroutine cam_grid_set_map + + !--------------------------------------------------------------------------- + ! + ! cam_grid_local_size: return the local size of a 2D array on this grid + ! + !--------------------------------------------------------------------------- + integer function cam_grid_local_size(this) + + ! Dummy argument + class(cam_grid_t) :: this + + ! Local variable + character(len=128) :: errormsg + + if (.not. associated(this%map)) then + write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' + call endrun('cam_grid_local_size: '//trim(errormsg)) + else + cam_grid_local_size = this%map%num_elem() + end if + + end function cam_grid_local_size + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_lon_lat: Find the latitude and longitude for a given + ! grid map index. Note if point is not mapped + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_lon_lat(this, index, lon, lat, isMapped) + + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(in) :: index + real(r8), intent(out) :: lon + real(r8), intent(out) :: lat + logical, intent(out) :: isMapped + + ! Local variables + integer :: latindex, lonindex + character(len=*), parameter :: subname = "cam_grid_get_lon_lat" + + if (this%block_indexed) then + lonindex = index + latindex = index + isMapped = this%map%is_mapped(index) + else + call this%map%coord_vals(index, lonindex, latindex, isMapped) + end if + + !!XXgoldyXX: May be able to relax all the checks + if ( (latindex < LBOUND(this%lat_coord%values, 1)) .or. & + (latindex > UBOUND(this%lat_coord%values, 1))) then + call endrun(trim(subname)//": index out of range for latvals") + else + lat = this%lat_coord%values(latindex) + end if + + if ( (lonindex < LBOUND(this%lon_coord%values, 1)) .or. & + (lonindex > UBOUND(this%lon_coord%values, 1))) then + call endrun(trim(subname)//": index out of range for lonvals") + else + lon = this%lon_coord%values(lonindex) + end if + + end subroutine cam_grid_get_lon_lat + + !--------------------------------------------------------------------------- + ! + ! cam_grid_find_src_dims: Find the correct src array dims for this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_find_src_dims(this, field_dnames, src_out) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(in) :: field_dnames(:) + integer, pointer :: src_out(:) + + ! Local variables + integer :: i, j + integer :: num_coords + character(len=max_hcoordname_len) :: coord_dimnames(2) + + call this%dim_names(coord_dimnames(1), coord_dimnames(2)) + if (associated(src_out)) then + deallocate(src_out) + nullify(src_out) + end if + if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then + num_coords = 1 + else + num_coords = 2 + end if + allocate(src_out(2)) ! Currently, all cases have two source dims + do i = 1, num_coords + do j = 1, size(field_dnames) + if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then + src_out(i) = j + end if + end do + end do + if (num_coords < 2) then + src_out(2) = -1 ! Assume a block structure for unstructured grids + end if + + end subroutine cam_grid_find_src_dims + + !--------------------------------------------------------------------------- + ! + ! cam_grid_find_dest_dims: Find the correct file array dims for this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(in) :: file_dnames(:) + integer, pointer :: dest_out(:) + + ! Local variables + integer :: i, j + integer :: num_coords + character(len=max_hcoordname_len) :: coord_dimnames(2) + + call this%dim_names(coord_dimnames(1), coord_dimnames(2)) + if (associated(dest_out)) then + deallocate(dest_out) + nullify(dest_out) + end if + if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then + num_coords = 1 + else + num_coords = 2 + end if + allocate(dest_out(num_coords)) + dest_out = 0 + do i = 1, num_coords + do j = 1, size(file_dnames) + if (trim(file_dnames(j)) == trim(coord_dimnames(i))) then + dest_out(i) = j + end if + end do + end do + + end subroutine cam_grid_find_dest_dims + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_pio_decomp: Find or create a PIO decomp on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & + iodesc, field_dnames, file_dnames) + use pio, only: io_desc_t + use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation + + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(in) :: field_lens(:) + integer, intent(in) :: file_lens(:) + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + character(len=*), optional, intent(in) :: field_dnames(:) + character(len=*), optional, intent(in) :: file_dnames(:) + + ! Local variables + integer, pointer :: src_in(:) + integer, pointer :: dest_in(:) + integer, allocatable :: permutation(:) + logical :: is_perm + character(len=128) :: errormsg + + nullify(src_in) + nullify(dest_in) + is_perm = .false. + if (.not. associated(this%map)) then + write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' + call endrun('cam_grid_get_pio_decomp: '//trim(errormsg)) + else + if (present(field_dnames)) then + call this%find_src_dims(field_dnames, src_in) + end if + if (present(file_dnames)) then + call this%find_dest_dims(file_dnames, dest_in) + end if + if (present(file_dnames) .and. present(field_dnames)) then + ! This only works if the arrays are the same size + if (size(file_dnames) == size(field_dnames)) then + allocate(permutation(size(file_dnames))) + call calc_permutation(file_dnames, field_dnames, permutation, is_perm) + end if + end if + ! Call cam_pio_get_decomp with the appropriate options + if (present(field_dnames) .and. present(file_dnames)) then + if (is_perm) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, field_dist_in=src_in, file_dist_in=dest_in, & + permute=permutation) + else + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, field_dist_in=src_in, file_dist_in=dest_in) + end if + else if (present(field_dnames)) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, field_dist_in=src_in) + else if (present(file_dnames)) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, file_dist_in=dest_in) + else + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%map) end if - gridloc = this%map%num_elem() - unstructured = this%is_unstructured() - call this%coord_lengths(dims) - if (associated(patch%mask)) then - if (patch%mask%num_elem() /= gridloc) then - ! The mask needs to be the same size as the map - call endrun(subname//': mask is incorrect size') - ! No else, just needed a check - ! In particular, we are not zeroing the mask since multiple - ! calls the same mask can be used for collected-column output - ! NB: Compacting the mask must be done after all calls (for a - ! particular mask) to this function. - end if - if (patch%collected_columns .neqv. cco) then - call endrun(subname//': collected_column mismatch') - end if + end if + if (associated(src_in)) then + deallocate(src_in) + nullify(src_in) + end if + if (associated(dest_in)) then + deallocate(dest_in) + nullify(dest_in) + end if + if (allocated(permutation)) then + deallocate(permutation) + end if + + end subroutine cam_grid_get_pio_decomp + + !------------------------------------------------------------------------------- + ! + ! cam_grid_find_dimids: Find the dimension NetCDF IDs on for this grid + ! + !------------------------------------------------------------------------------- + subroutine cam_grid_find_dimids(this, File, dimids) + use pio, only: file_desc_t, pio_noerr, pio_inq_dimid + use pio, only: pio_seterrorhandling, pio_bcast_error + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(out) :: dimids(:) + + ! Local vaariables + integer :: ierr + integer :: err_handling + character(len=max_hcoordname_len) :: dimname1, dimname2 + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) + + call this%dim_names(dimname1, dimname2) + if (size(dimids) < 1) then + call endrun('CAM_GRID_FIND_DIMIDS: dimids must have positive size') + end if + dimids = -1 + ! Check the first dimension + ierr = pio_inq_dimid(File, trim(dimname1), dimids(1)) + if(ierr /= PIO_NOERR) then + call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname1)//', does not exist on file') + end if + if (trim(dimname1) /= trim(dimname2)) then + ! Structured grid, find second dimid + if (size(dimids) < 2) then + call endrun('CAM_GRID_FIND_DIMIDS: dimids too small for '//trim(this%name)) + end if + ierr = pio_inq_dimid(File, trim(dimname2), dimids(2)) + if(ierr /= PIO_NOERR) then + call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname2)//', does not exist on file') + end if + end if + + ! Back to whatever error handling was running before this routine + call pio_seterrorhandling(File, err_handling) + + end subroutine cam_grid_find_dimids + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_2d_int: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_2d_int(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_int: Error reading variable') + end subroutine cam_grid_read_darray_2d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_3d_int: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_3d_int(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_int: Error reading variable') + end subroutine cam_grid_read_darray_3d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_2d_double: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_2d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_double: Error reading variable') + end subroutine cam_grid_read_darray_2d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_3d_double: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_double: Error reading variable') + end subroutine cam_grid_read_darray_3d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_2d_real: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_2d_real(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_real: Error reading variable') + end subroutine cam_grid_read_darray_2d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_read_darray_3d_real: Read a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_read_darray_3d_real(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_: Error reading variable') + end subroutine cam_grid_read_darray_3d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_2d_int: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_INT + + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_int: Error writing variable') + end subroutine cam_grid_write_darray_2d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_3d_int: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_int: Error writing variable') + end subroutine cam_grid_write_darray_3d_int + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_2d_double: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_double: Error writing variable') + end subroutine cam_grid_write_darray_2d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_3d_double: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_double: Error writing variable') + + end subroutine cam_grid_write_darray_3d_double + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_2d_real: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_real: Error writing variable') + end subroutine cam_grid_write_darray_2d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_3d_real: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + nullify(iodesc) + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_real: Error writing variable') + end subroutine cam_grid_write_darray_3d_real + + !--------------------------------------------------------------------------- + ! + ! cam_grid_get_patch_mask: Compute a map which is defined for locations + ! within the input patch. + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco) + use mpi, only: mpi_min, mpi_max, mpi_real8 + use spmd_utils, only: mpicom + use physconst, only: pi + + ! Dummy arguments + class(cam_grid_t) :: this + real(r8), intent(in) :: lonl, lonu ! Longitude bounds + real(r8), intent(in) :: latl, latu ! Latitude bounds + type(cam_grid_patch_t), intent(inout) :: patch + logical, intent(in) :: cco ! Collect columns? + + ! Local arguments + real(r8) :: mindist, minlondist + real(r8) :: dist, temp1, temp2 ! Test distance calc + real(r8) :: londeg, latdeg + real(r8) :: lon, lat + real(r8) :: londeg_min, latdeg_min + real(r8) :: lonmin, lonmax, latmin, latmax + integer :: minind ! Location of closest point + integer :: mapind ! Grid map index + integer :: latind, lonind + integer :: ierr ! For MPI calls + integer :: dims(2) ! Global dim sizes + integer :: gridloc ! local size of grid + logical :: unstructured ! grid type + logical :: findClosest ! .false. == patch output + logical :: isMapped ! .true. iff point in map + + real(r8), parameter :: maxangle = pi / 4.0_r8 + real(r8), parameter :: deg2rad = pi / 180.0_r8 + real(r8), parameter :: maxtol = 0.99999_r8 ! max cos value + real(r8), parameter :: maxlat = pi * maxtol / 2.0_r8 + character(len=*), parameter :: subname = 'cam_grid_get_patch_mask' + + if (.not. associated(this%map)) then + call endrun('cam_grid_get_patch_mask: Grid, '//trim(this%name)//', has no map') + end if + gridloc = this%map%num_elem() + unstructured = this%is_unstructured() + call this%coord_lengths(dims) + if (associated(patch%mask)) then + if (patch%mask%num_elem() /= gridloc) then + ! The mask needs to be the same size as the map + call endrun(subname//': mask is incorrect size') + ! No else, just needed a check + ! In particular, we are not zeroing the mask since multiple calls with + ! the same mask can be used for collected-column output + ! NB: Compacting the mask must be done after all calls (for a + ! particular mask) to this function. + end if + if (patch%collected_columns .neqv. cco) then + call endrun(subname//': collected_column mismatch') + end if + else + if (associated(patch%latmap)) then + call endrun(subname//': unallocated patch has latmap') + end if + if (associated(patch%lonmap)) then + call endrun(subname//': unallocated patch has lonmap') + end if + call patch%set_patch(lonl, lonu, latl, latu, cco, this%id, this%map) + if (patch%mask%num_elem() /= gridloc) then + ! Basic check to make sure the copy worked + call endrun(subname//': grid map is invalid') + end if + call patch%mask%clear() + ! Set up the lat/lon maps + if (cco) then + ! For collected column output, we need to collect coordinates and values + allocate(patch%latmap(patch%mask%num_elem())) + patch%latmap = 0 + allocate(patch%latvals(patch%mask%num_elem())) + patch%latvals = 91.0_r8 + allocate(patch%lonmap(patch%mask%num_elem())) + patch%lonmap = 0 + allocate(patch%lonvals(patch%mask%num_elem())) + patch%lonvals = 361.0_r8 else - if (associated(patch%latmap)) then - call endrun(subname//': unallocated patch has latmap') - end if - if (associated(patch%lonmap)) then - call endrun(subname//': unallocated patch has lonmap') - end if - call patch%set_patch(lonl, lonu, latl, latu, cco, this%id, this%map) - if (patch%mask%num_elem() /= gridloc) then - ! Basic check to make sure the copy worked - call endrun(subname//': grid map is invalid') - end if - call patch%mask%clear() - ! Set up the lat/lon maps - if (cco) then - ! For collected column output, we need to collect - ! coordinates and values - allocate(patch%latmap(patch%mask%num_elem())) - patch%latmap = 0 - allocate(patch%latvals(patch%mask%num_elem())) - patch%latvals = 91.0_r8 - allocate(patch%lonmap(patch%mask%num_elem())) - patch%lonmap = 0 - allocate(patch%lonvals(patch%mask%num_elem())) - patch%lonvals = 361.0_r8 - else - if (associated(this%lat_coord%values)) then - allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1))) - patch%latmap = 0 - else - nullify(patch%latmap) - end if - if (associated(this%lon_coord%values)) then - allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1))) - patch%lonmap = 0 - else - nullify(patch%lonmap) + if (associated(this%lat_coord%values)) then + allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1))) + patch%latmap = 0 + else + nullify(patch%latmap) + end if + if (associated(this%lon_coord%values)) then + allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1))) + patch%lonmap = 0 + else + nullify(patch%lonmap) + end if + end if + end if + + ! We have to iterate through each grid point to check + ! We have four cases, structured vs. unstructured grid * + ! patch area vs. closest column + ! Note that a 1-d patch 'area' is not allowed for unstructured grids + findClosest = .false. + ! Make sure our search items are in order + lonmin = min(lonl, lonu) + lonmax = max(lonl, lonu) + latmin = min(latl, latu) + latmax = max(latl, latu) + if (lonl == lonu) then + if (latl == latu) then + findClosest = .true. + else if (unstructured) then + call endrun(subname//': 1-D patch (lon) not allowed for unstructured grids') + else + ! Find closest lon line to lonu + ! This is a lat lon grid so it should have coordinate axes + lonmin = 365.0_r8 + mindist = 365.0_r8 + if (associated(this%lon_coord%values)) then + do lonind = LBOUND(this%lon_coord%values, 1), UBOUND(this%lon_coord%values, 1) + dist = abs(this%lon_coord%values(lonind) - lonu) + if (dist < mindist) then + lonmin = this%lon_coord%values(lonind) + mindist = dist end if - end if - end if - - ! We have to iterate through each grid point to check - ! We have four cases, structured vs. unstructured grid * - ! patch area vs. closest column - ! Note that a 1-d patch 'area' is not allowed for unstructured grids - findClosest = .false. - ! Make sure our search items are in order - lonmin = min(lonl, lonu) - lonmax = max(lonl, lonu) - latmin = min(latl, latu) - latmax = max(latl, latu) - if (lonl == lonu) then - if (latl == latu) then - findClosest = .true. - else if (unstructured) then - call endrun(subname//': 1-D patch (lon) not allowed for unstructured grids') - else - ! Find closest lon line to lonu - ! This is a lat lon grid so it should have coordinate axes - lonmin = 365.0_r8 - mindist = 365.0_r8 - if (associated(this%lon_coord%values)) then - do lonind = LBOUND(this%lon_coord%values, 1), UBOUND(this%lon_coord%values, 1) - dist = abs(this%lon_coord%values(lonind) - lonu) - if (dist < mindist) then - lonmin = this%lon_coord%values(lonind) - mindist = dist - end if - end do + end do + end if + ! Get the global minimum + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) + if (dist == mindist) then + ! We have a ringer so use only that longitude + lonmax = lonmin + else + ! We don't have a minimum dist so count no points + lonmax = lonmin - 1.0_r8 + end if + end if + else if (latl == latu) then + if (unstructured) then + call endrun(subname//': 1-D patch (lat) not allowed for unstructured grids') + else + ! Find closest lat line to latu + ! This is a lat lon grid so it should have coordinate axes + latmin = 91.0_r8 + mindist = 181.0_r8 + if (associated(this%lat_coord%values)) then + do latind = LBOUND(this%lat_coord%values, 1), UBOUND(this%lat_coord%values, 1) + dist = abs(this%lat_coord%values(latind) - latl) + if (dist < mindist) then + latmin = this%lat_coord%values(latind) + mindist = dist end if - ! Get the global minimum - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) - if (dist == mindist) then - ! We have a ringer so use only that longitude - lonmax = lonmin + end do + end if + ! Get the global minimum + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) + if (dist == mindist) then + ! We have a ringer so use only that latitude + latmax = latmin + else + ! We don't have a minimum dist so count no points + latmax = latmin - 1.0_r8 + end if + end if + end if + + ! Convert to radians + lonmin = lonmin * deg2rad + lonmax = lonmax * deg2rad + latmin = latmin * deg2rad + latmax = latmax * deg2rad + ! Loop through all the local grid elements and find the closest match + ! (or all matches depending on the value of findClosest) + minind = -1 + londeg_min = 361.0_r8 + latdeg_min = 91.0_r8 + mindist = 2.0_r8 * pi + + do mapind = 1, patch%mask%num_elem() + call this%get_lon_lat(mapind, londeg, latdeg, isMapped) + if (isMapped) then + lon = londeg * deg2rad + lat = latdeg * deg2rad + if (findClosest) then + ! Use the Spherical Law of Cosines to find the great-circle distance. + ! Might as well use the unit sphere since we just want differences + if ( (abs(lat - latmin) <= maxangle) .and. & + (abs(lon - lonmin) <= maxangle)) then + ! maxangle could be pi but why waste all those trig functions? + ! XXgoldyXX: What should we use for maxangle given coarse Eul grids? + if ((lat == latmin) .and. (lon == lonmin)) then + dist = 0.0_r8 else - ! We don't have a minimum dist so count no points - lonmax = lonmin - 1.0_r8 - end if - end if - else if (latl == latu) then - if (unstructured) then - call endrun(subname//': 1-D patch (lat) not allowed for unstructured grids') - else - ! Find closest lat line to latu - ! This is a lat lon grid so it should have coordinate axes - latmin = 91.0_r8 - mindist = 181.0_r8 - if (associated(this%lat_coord%values)) then - do latind = LBOUND(this%lat_coord%values, 1), & - UBOUND(this%lat_coord%values, 1) - dist = abs(this%lat_coord%values(latind) - latl) - if (dist < mindist) then - latmin = this%lat_coord%values(latind) - mindist = dist - end if - end do + temp1 = (sin(latmin) * sin(lat)) + & + (cos(latmin) * cos(lat) * cos(lon - lonmin)) + if (temp1 > maxtol) then + ! Use haversine formula + temp1 = sin(latmin - lat) + temp2 = sin((lonmin - lon) / 2.0_r8) + dist = 2.0_r8 * asin((temp1*temp1) + (cos(latmin)*cos(lat)*temp2*temp2)) + else + dist = acos(temp1) + end if end if - ! Get the global minimum - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, & - mpicom, ierr) - if (dist == mindist) then - ! We have a ringer so use only that latitude - latmax = latmin - else - ! We don't have a minimum dist so count no points - latmax = latmin - 1.0_r8 + if ( (dist < mindist) .or. & + ((dist == mindist) .and. & + (abs(lon - lonmin) < abs(londeg_min*deg2rad - lonmin)))) then + minind = mapind + mindist = dist + londeg_min = londeg + latdeg_min = latdeg end if - end if - end if - - ! Convert to radians - lonmin = lonmin * deg2rad - lonmax = lonmax * deg2rad - latmin = latmin * deg2rad - latmax = latmax * deg2rad - ! Loop through all the local grid elements and find the closest match - ! (or all matches depending on the value of findClosest) - minind = -1 - londeg_min = 361.0_r8 - latdeg_min = 91.0_r8 - mindist = 2.0_r8 * pi - - do mapind = 1, patch%mask%num_elem() - call this%get_lon_lat(mapind, londeg, latdeg, isMapped) - if (isMapped) then - lon = londeg * deg2rad - lat = latdeg * deg2rad - if (findClosest) then - ! Use the Spherical Law of Cosines to find the great-circle distance. - ! Might as well use the unit sphere since we just want differences - if ( (abs(lat - latmin) <= maxangle) .and. & - (abs(lon - lonmin) <= maxangle)) then - ! maxangle could be pi but why waste all those trig functions? - ! XXgoldyXX: What should we use for maxangle given coarse Eul grids? - if ((lat == latmin) .and. (lon == lonmin)) then - dist = 0.0_r8 - else - temp1 = (sin(latmin) * sin(lat)) + & - (cos(latmin) * cos(lat) * cos(lon - lonmin)) - if (temp1 > maxtol) then - ! Use haversine formula - temp1 = sin(latmin - lat) - temp2 = sin((lonmin - lon) / 2.0_r8) - dist = 2.0_r8 * asin((temp1*temp1) + & - (cos(latmin)*cos(lat)*temp2*temp2)) - else - dist = acos(temp1) - end if + end if + else + if ( (latmin <= lat) .and. (lat <= latmax) .and. & + (lonmin <= lon) .and. (lon <= lonmax)) then + if (patch%mask%num_elem() >= mapind) then + if (.not. patch%mask%is_mapped(mapind)) then + call patch%mask%copy_elem(this%map, mapind) + patch%num_points = patch%num_points + 1 + if (cco) then + if (patch%num_points > size(patch%latvals, 1)) then + call endrun(subname//': Number of cols larger than mask!?') end if - if ( (dist < mindist) .or. & - ((dist == mindist) .and. & - (abs(lon - lonmin) < abs(londeg_min*deg2rad - lonmin)))) then - minind = mapind - mindist = dist - londeg_min = londeg - latdeg_min = latdeg + call this%map%coord_dests(mapind, lonind, latind) + if (latind > 0) then + ! Grid is structured, get unique index + lonind = lonind + (latind * dims(1)) end if - end if - else - if ( (latmin <= lat) .and. (lat <= latmax) .and. & - (lonmin <= lon) .and. (lon <= lonmax)) then - if (patch%mask%num_elem() >= mapind) then - if (.not. patch%mask%is_mapped(mapind)) then - call patch%mask%copy_elem(this%map, mapind) - patch%num_points = patch%num_points + 1 - if (cco) then - if (patch%num_points > size(patch%latvals, 1)) then - call endrun(subname//': Number of cols larger than mask!?') - end if - call this%map%coord_dests(mapind, lonind, latind) - if (latind > 0) then - ! Grid is structured, get unique index - lonind = lonind + (latind * dims(1)) - end if - patch%latmap(patch%num_points) = lonind - patch%latvals(patch%num_points) = latdeg - patch%lonmap(patch%num_points) = lonind - patch%lonvals(patch%num_points) = londeg - else if ((this%block_indexed) .or. unstructured) then - call this%map%coord_dests(mapind, lonind, latind) - if (latind == 0) then - latind = lonind - end if - if (associated(patch%latmap)) then - patch%latmap(mapind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(mapind) = lonind - end if - else - call this%map%coord_vals(mapind, lonind, latind) - if (associated(patch%latmap)) then - patch%latmap(latind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(lonind) = lonind - end if - end if - ! else do nothing, we already found this point - end if - else - call endrun(subname//': PE has patch points but mask too small') + patch%latmap(patch%num_points) = lonind + patch%latvals(patch%num_points) = latdeg + patch%lonmap(patch%num_points) = lonind + patch%lonvals(patch%num_points) = londeg + else if ((this%block_indexed) .or. unstructured) then + call this%map%coord_dests(mapind, lonind, latind) + if (latind == 0) then + latind = lonind end if - end if - end if ! findClosest - end if ! isMapped - end do - if (findClosest) then - ! We need to find the minimum mindist and use only that value - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) - ! Special case for pole points - if (latdeg_min > 90.0_r8) then - temp1 = 0.0_r8 - else - temp1 = abs(latdeg_min*deg2rad) - end if - call MPI_allreduce(temp1, lat, 1, mpi_real8, mpi_max, mpicom, ierr) - if ((abs(latmin) > maxlat) .or. (lat > maxlat)) then - if (dist == mindist) then - ! Only distance winners can compete - lon = abs(londeg_min - lonl) + if (associated(patch%latmap)) then + patch%latmap(mapind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(mapind) = lonind + end if + else + call this%map%coord_vals(mapind, lonind, latind) + if (associated(patch%latmap)) then + patch%latmap(latind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(lonind) = lonind + end if + end if + ! else do nothing, we already found this point + end if else - lon = 361.0_r8 + call endrun(subname//': PE has patch points but mask too small') end if - call MPI_allreduce(lon, minlondist, 1, mpi_real8, mpi_min, mpicom, ierr) - ! Kill the losers - if (lon /= minlondist) then - dist = dist + 1.0_r8 - end if - end if - ! Now, only task(s) which have real minimum distance should set their mask - ! minind test allows for no match - if (dist == mindist) then - if (minind < 0) then - call endrun("cam_grid_get_patch_mask: No closest point found!!") - else - if (patch%mask%num_elem() >= minind) then - if (.not. patch%mask%is_mapped(minind)) then - call patch%mask%copy_elem(this%map, minind) - patch%num_points = patch%num_points + 1 - if (cco) then - if (patch%num_points > size(patch%latvals, 1)) then - call endrun(subname//': Number of columns larger than mask!?') - end if - call this%map%coord_dests(minind, lonind, latind) - if (latind > 0) then - ! Grid is structured, get unique index - lonind = lonind + (latind * dims(1)) - end if - patch%latmap(patch%num_points) = lonind - patch%latvals(patch%num_points) = latdeg_min - patch%lonmap(patch%num_points) = lonind - patch%lonvals(patch%num_points) = londeg_min - else if ((this%block_indexed) .or. unstructured) then - call this%map%coord_dests(minind, lonind, latind) - if (latind == 0) then - latind = lonind - end if - if (associated(patch%latmap)) then - patch%latmap(minind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(minind) = lonind - end if - else - call this%map%coord_vals(minind, lonind, latind) - if (associated(patch%latmap)) then - patch%latmap(latind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(lonind) = lonind - end if - end if - ! else do nothing, we already found this point - end if - else - call endrun(subname//': PE has patch closest point but mask too small') - end if + end if + end if ! findClosest + end if ! isMapped + end do + if (findClosest) then + ! We need to find the minimum mindist and use only that value + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) + ! Special case for pole points + if (latdeg_min > 90.0_r8) then + temp1 = 0.0_r8 + else + temp1 = abs(latdeg_min*deg2rad) + end if + call MPI_allreduce(temp1, lat, 1, mpi_real8, mpi_max, mpicom, ierr) + if ((abs(latmin) > maxlat) .or. (lat > maxlat)) then + if (dist == mindist) then + ! Only distance winners can compete + lon = abs(londeg_min - lonl) + else + lon = 361.0_r8 + end if + call MPI_allreduce(lon, minlondist, 1, mpi_real8, mpi_min, mpicom, ierr) + ! Kill the losers + if (lon /= minlondist) then + dist = dist + 1.0_r8 + end if + end if + ! Now, only task(s) which have real minimum distance should set their mask + ! minind test allows for no match + if (dist == mindist) then + if (minind < 0) then + call endrun("cam_grid_get_patch_mask: No closest point found!!") + else + if (patch%mask%num_elem() >= minind) then + if (.not. patch%mask%is_mapped(minind)) then + call patch%mask%copy_elem(this%map, minind) + patch%num_points = patch%num_points + 1 + if (cco) then + if (patch%num_points > size(patch%latvals, 1)) then + call endrun(subname//': Number of columns larger than mask!?') + end if + call this%map%coord_dests(minind, lonind, latind) + if (latind > 0) then + ! Grid is structured, get unique index + lonind = lonind + (latind * dims(1)) + end if + patch%latmap(patch%num_points) = lonind + patch%latvals(patch%num_points) = latdeg_min + patch%lonmap(patch%num_points) = lonind + patch%lonvals(patch%num_points) = londeg_min + else if ((this%block_indexed) .or. unstructured) then + call this%map%coord_dests(minind, lonind, latind) + if (latind == 0) then + latind = lonind + end if + if (associated(patch%latmap)) then + patch%latmap(minind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(minind) = lonind + end if + else + call this%map%coord_vals(minind, lonind, latind) + if (associated(patch%latmap)) then + patch%latmap(latind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(lonind) = lonind + end if + end if + ! else do nothing, we already found this point end if - end if - end if ! findClosest - - end subroutine cam_grid_get_patch_mask - - !------------------------------------------------------------------------ - ! - ! Grid Patch functions - ! - !------------------------------------------------------------------------ - - integer function cam_grid_patch_get_id(this) result(id) - - ! Dummy argument - class(cam_grid_patch_t) :: this + else + call endrun(subname//': PE has patch closest point but mask too small') + end if + end if + end if + end if ! findClosest - id = this%grid_id - end function cam_grid_patch_get_id + end subroutine cam_grid_get_patch_mask - subroutine cam_grid_patch_get_global_size_map(this, gsize) + !--------------------------------------------------------------------------- + ! + ! Grid Patch functions + ! + !--------------------------------------------------------------------------- - ! Dummy arguments - class(cam_grid_patch_t), intent(in) :: this - integer, intent(out) :: gsize + integer function cam_grid_patch_get_id(this) result(id) - gsize = this%global_size + ! Dummy argument + class(cam_grid_patch_t) :: this - end subroutine cam_grid_patch_get_global_size_map + id = this%grid_id + end function cam_grid_patch_get_id - subroutine cam_grid_patch_get_global_size_axes(this, latsize, lonsize) + subroutine cam_grid_patch_get_global_size_map(this, gsize) - ! Dummy arguments - class(cam_grid_patch_t), intent(in) :: this - integer, intent(out) :: latsize - integer, intent(out) :: lonsize + ! Dummy arguments + class(cam_grid_patch_t), intent(in) :: this + integer, intent(out) :: gsize - latsize = this%global_lat_size - lonsize = this%global_lon_size + gsize = this%global_size - end subroutine cam_grid_patch_get_global_size_axes + end subroutine cam_grid_patch_get_global_size_map - ! cam_grid_patch_get_axis_names - ! Collect or compute unique names for the latitude and longitude axes - ! If the grid is unstructured or col_output is .true., the column - ! dimension name is also generated (e.g., ncol) - subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, & - col_name, col_output) + subroutine cam_grid_patch_get_global_size_axes(this, latsize, lonsize) - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(out) :: lat_name - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: col_name - logical, intent(in) :: col_output - - ! Local variable - integer :: index - character(len=120) :: errormsg - character(len=max_hcoordname_len) :: grid_name - logical :: unstruct - - if (cam_grid_check(this%grid_id)) then - index = this%grid_index() - unstruct = cam_grids(index)%is_unstructured() - ! Get coordinate and dim names - call cam_grids(index)%lat_coord%get_coord_name(lat_name) - call cam_grids(index)%lon_coord%get_coord_name(lon_name) - grid_name = cam_grids(index)%name - if (col_output .or. unstruct) then - ! In this case, we are using collect_column_output on a lat/lon grid - col_name = 'ncol_'//trim(grid_name) - lat_name = trim(lat_name)//'_'//trim(grid_name) - lon_name = trim(lon_name)//'_'//trim(grid_name) - else - ! Separate patch output for a lat/lon grid - col_name = '' - lat_name = trim(lat_name)//'_'//trim(grid_name) - lon_name = trim(lon_name)//'_'//trim(grid_name) - end if - else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_axis_names: '//errormsg) - end if + ! Dummy arguments + class(cam_grid_patch_t), intent(in) :: this + integer, intent(out) :: latsize + integer, intent(out) :: lonsize - end subroutine cam_grid_patch_get_axis_names + latsize = this%global_lat_size + lonsize = this%global_lon_size - subroutine cam_grid_patch_get_coord_long_name(this, axis, name) + end subroutine cam_grid_patch_get_global_size_axes - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(in) :: axis - character(len=*), intent(out) :: name - - ! Local variable - character(len=120) :: errormsg - integer :: index - - if (cam_grid_check(this%grid_id)) then - index = this%grid_index() - if (trim(axis) == 'lat') then - call cam_grids(index)%lat_coord%get_long_name(name) - else if (trim(axis) == 'lon') then - call cam_grids(index)%lon_coord%get_long_name(name) - else - write(errormsg, *) 'Bad axis name:', axis - call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) - end if - else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) - end if + ! cam_grid_patch_get_axis_names + ! Collect or compute unique names for the latitude and longitude axes + ! If the grid is unstructured or col_output is .true., the column + ! dimension name is also generated (e.g., ncol) + subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, & + col_name, col_output) - end subroutine cam_grid_patch_get_coord_long_name + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(out) :: lat_name + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: col_name + logical, intent(in) :: col_output - subroutine cam_grid_patch_get_coord_units(this, axis, units) + ! Local variable + integer :: index + character(len=120) :: errormsg + character(len=max_hcoordname_len) :: grid_name + logical :: unstruct - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(in) :: axis - character(len=*), intent(out) :: units - - ! Local variable - character(len=120) :: errormsg - integer :: index - - if (cam_grid_check(this%grid_id)) then - index = this%grid_index() - if (trim(axis) == 'lat') then - call cam_grids(index)%lat_coord%get_units(units) - else if (trim(axis) == 'lon') then - call cam_grids(index)%lon_coord%get_units(units) - else - write(errormsg, *) 'Bad axis name:', axis - call endrun('cam_grid_patch_get_coord_units: '//errormsg) - end if + if (cam_grid_check(this%grid_id)) then + index = this%grid_index() + unstruct = cam_grids(index)%is_unstructured() + ! Get coordinate and dim names + call cam_grids(index)%lat_coord%get_coord_name(lat_name) + call cam_grids(index)%lon_coord%get_coord_name(lon_name) + grid_name = cam_grids(index)%name + if (col_output .or. unstruct) then + ! In this case, we are using collect_column_output on a lat/lon grid + col_name = 'ncol_'//trim(grid_name) + lat_name = trim(lat_name)//'_'//trim(grid_name) + lon_name = trim(lon_name)//'_'//trim(grid_name) else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_coord_units: '//errormsg) - end if - - end subroutine cam_grid_patch_get_coord_units - - subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, & - id, map) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - real(r8), intent(in) :: lonl, lonu ! Longitude bounds - real(r8), intent(in) :: latl, latu ! Latitude bounds - logical, intent(in) :: cco ! Collect columns? - integer, intent(in) :: id - type(cam_filemap_t), intent(in) :: map - - this%grid_id = id - this%lon_range(1) = lonl - this%lon_range(2) = lonu - this%lat_range(1) = latl - this%lat_range(2) = latu - this%collected_columns = cco - if (.not. associated(this%mask)) then - allocate(this%mask) + ! Separate patch output for a lat/lon grid + col_name = '' + lat_name = trim(lat_name)//'_'//trim(grid_name) + lon_name = trim(lon_name)//'_'//trim(grid_name) end if - call this%mask%copy(map) - call this%mask%new_index() - - end subroutine cam_grid_patch_set_patch - - subroutine cam_grid_patch_get_decomp(this, field_lens, file_lens, & - dtype, iodesc, file_dest_in) - use pio, only: io_desc_t - use cam_pio_utils, only: cam_pio_get_decomp + else + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_axis_names: '//errormsg) + end if - ! Dummy arguments - class(cam_grid_patch_t) :: this - integer, intent(in) :: field_lens(:) - integer, intent(in) :: file_lens(:) - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - integer, optional, intent(in) :: file_dest_in(:) - - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%mask, file_dist_in=file_dest_in) + end subroutine cam_grid_patch_get_axis_names - end subroutine cam_grid_patch_get_decomp + subroutine cam_grid_patch_get_coord_long_name(this, axis, name) - subroutine cam_grid_patch_compact(this, collected_output) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - logical, optional, intent(in) :: collected_output + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(in) :: axis + character(len=*), intent(out) :: name - ! Local variables - integer :: index ! Our grid's index - logical :: dups_ok + ! Local variable + character(len=120) :: errormsg + integer :: index + if (cam_grid_check(this%grid_id)) then index = this%grid_index() - if (index > 0) then - dups_ok = cam_grids(index)%is_unstructured() + if (trim(axis) == 'lat') then + call cam_grids(index)%lat_coord%get_long_name(name) + else if (trim(axis) == 'lon') then + call cam_grids(index)%lon_coord%get_long_name(name) else - ! This is probably an error condition but someone else will - ! catch it first - dups_ok = .false. + write(errormsg, *) 'Bad axis name:', axis + call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) end if - if (present(collected_output)) then - dups_ok = dups_ok .or. collected_output - end if - call this%mask%compact(this%lonmap, this%latmap, & - num_lons=this%global_lon_size, num_lats=this%global_lat_size, & - num_mapped=this%global_size, columnize=collected_output, & - dups_ok_in=dups_ok) - - end subroutine cam_grid_patch_compact + else + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) + end if - subroutine cam_grid_patch_get_active_cols(this, lchnk, active, srcdim_in) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - integer, intent(in) :: lchnk - logical, intent(out) :: active(:) - integer, optional, intent(in) :: srcdim_in + end subroutine cam_grid_patch_get_coord_long_name - if (.not. associated(this%mask)) then - call endrun('cam_grid_patch_get_active_cols: No mask') - else - call this%mask%active_cols(lchnk, active, srcdim_in) - end if + subroutine cam_grid_patch_get_coord_units(this, axis, units) - end subroutine cam_grid_patch_get_active_cols + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(in) :: axis + character(len=*), intent(out) :: units - ! cam_grid_patch_write_vals: Write lat and lon coord values to File - subroutine cam_grid_patch_write_vals(this, File, header_info) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use pio, only: pio_freedecomp - use cam_pio_utils, only: cam_pio_handle_error, cam_pio_newdecomp + ! Local variable + character(len=120) :: errormsg + integer :: index - ! Dummy arguments - class(cam_grid_patch_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - type(cam_grid_header_info_t), intent(inout) :: header_info - - ! Local variables - type(io_desc_t), pointer :: iodesc - type(var_desc_t), pointer :: vdesc - real(r8), pointer :: coord_p(:) - real(r8), pointer :: coord(:) - integer(iMap), pointer :: map(:) - integer :: field_lens(1) - integer :: file_lens(1) - integer :: ierr - character(len=*), parameter :: subname = 'CAM_GRID_PATCH_WRITE_VALS' - - nullify(vdesc) - nullify(coord_p) - nullify(coord) - nullify(map) - nullify(iodesc) - if (this%grid_id /= header_info%get_gridid()) then - call endrun(subname//': Grid id mismatch') - end if - ! Write out lon - if (associated(this%lonmap)) then - field_lens(1) = size(this%lonmap, 1) - map => this%lonmap + if (cam_grid_check(this%grid_id)) then + index = this%grid_index() + if (trim(axis) == 'lat') then + call cam_grids(index)%lat_coord%get_units(units) + else if (trim(axis) == 'lon') then + call cam_grids(index)%lon_coord%get_units(units) else - field_lens(1) = 0 - allocate(map(0)) - end if - file_lens(1) = this%global_lon_size - !! XXgoldyXX: Think about caching these decomps - call cam_pio_newdecomp(iodesc, file_lens, map, pio_double) - if (associated(this%lonvals)) then - coord => this%lonvals + write(errormsg, *) 'Bad axis name:', axis + call endrun('cam_grid_patch_get_coord_units: '//errormsg) + end if + else + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_coord_units: '//errormsg) + end if + + end subroutine cam_grid_patch_get_coord_units + + subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, id, map) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + real(r8), intent(in) :: lonl, lonu ! Longitude bounds + real(r8), intent(in) :: latl, latu ! Latitude bounds + logical, intent(in) :: cco ! Collect columns? + integer, intent(in) :: id + type(cam_filemap_t), intent(in) :: map + + this%grid_id = id + this%lon_range(1) = lonl + this%lon_range(2) = lonu + this%lat_range(1) = latl + this%lat_range(2) = latu + this%collected_columns = cco + if (.not. associated(this%mask)) then + allocate(this%mask) + end if + call this%mask%copy(map) + call this%mask%new_index() + + end subroutine cam_grid_patch_set_patch + + subroutine cam_grid_patch_get_decomp(this, field_lens, file_lens, dtype, & + iodesc, file_dest_in) + use pio, only: io_desc_t + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_patch_t) :: this + integer, intent(in) :: field_lens(:) + integer, intent(in) :: file_lens(:) + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + integer, optional, intent(in) :: file_dest_in(:) + + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%mask, & + file_dist_in=file_dest_in) + + end subroutine cam_grid_patch_get_decomp + + subroutine cam_grid_patch_compact(this, collected_output) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + logical, optional, intent(in) :: collected_output + + ! Local variables + integer :: index ! Our grid's index + logical :: dups_ok + + index = this%grid_index() + if (index > 0) then + dups_ok = cam_grids(index)%is_unstructured() + else + ! This is probably an error condition but someone else will catch it first + dups_ok = .false. + end if + if (present(collected_output)) then + dups_ok = dups_ok .or. collected_output + end if + call this%mask%compact(this%lonmap, this%latmap, & + num_lons=this%global_lon_size, num_lats=this%global_lat_size, & + num_mapped=this%global_size, columnize=collected_output, & + dups_ok_in=dups_ok) + + end subroutine cam_grid_patch_compact + + subroutine cam_grid_patch_get_active_cols(this, lchnk, active, srcdim_in) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + integer, intent(in) :: lchnk + logical, intent(out) :: active(:) + integer, optional, intent(in) :: srcdim_in + + if (.not. associated(this%mask)) then + call endrun('cam_grid_patch_get_active_cols: No mask') + else + call this%mask%active_cols(lchnk, active, srcdim_in) + end if + + end subroutine cam_grid_patch_get_active_cols + + ! cam_grid_patch_write_vals: Write lat and lon coord values to File + subroutine cam_grid_patch_write_vals(this, File, header_info) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use pio, only: pio_initdecomp, pio_freedecomp + use cam_pio_utils, only: cam_pio_handle_error, pio_subsystem + + ! Dummy arguments + class(cam_grid_patch_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + type(cam_grid_header_info_t), intent(inout) :: header_info + + ! Local variables + type(io_desc_t) :: iodesc + type(var_desc_t), pointer :: vdesc + real(r8), pointer :: coord_p(:) + real(r8), pointer :: coord(:) + integer(iMap), pointer :: map(:) + integer :: field_lens(1) + integer :: file_lens(1) + integer :: ierr + + nullify(vdesc) + nullify(coord_p) + nullify(coord) + nullify(map) + if (this%grid_id /= header_info%get_gridid()) then + call endrun('CAM_GRID_PATCH_WRITE_VALS: Grid id mismatch') + end if + ! Write out lon + if (associated(this%lonmap)) then + field_lens(1) = size(this%lonmap, 1) + map => this%lonmap + else + field_lens(1) = 0 + allocate(map(0)) + end if + file_lens(1) = this%global_lon_size + !! XXgoldyXX: Think about caching these decomps + call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc) + if (associated(this%lonvals)) then + coord => this%lonvals + else + coord_p => cam_grid_get_lonvals(this%grid_id) + if (associated(coord_p)) then + coord => coord_p else - coord_p => cam_grid_get_lonvals(this%grid_id) - if (associated(coord_p)) then - coord => coord_p - else - allocate(coord(0)) - end if - end if - vdesc => header_info%get_lon_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing longitude') - if (.not. associated(this%lonmap)) then - deallocate(map) - nullify(map) - end if - if (.not. (associated(coord_p) .or. associated(this%lonvals))) then - deallocate(coord) - nullify(coord) - end if - ! Write out lat - if (associated(this%latmap)) then - field_lens(1) = size(this%latmap, 1) - map => this%latmap + allocate(coord(0)) + end if + end if + vdesc => header_info%get_lon_varid() + call pio_write_darray(File, vdesc, iodesc, coord, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing longitude') + if (.not. associated(this%lonmap)) then + deallocate(map) + nullify(map) + end if + if (.not. (associated(coord_p) .or. associated(this%lonvals))) then + deallocate(coord) + nullify(coord) + end if + call pio_freedecomp(File, iodesc) + ! Write out lat + if (associated(this%latmap)) then + field_lens(1) = size(this%latmap, 1) + map => this%latmap + else + field_lens(1) = 0 + allocate(map(0)) + end if + file_lens(1) = this%global_lat_size + !! XXgoldyXX: Think about caching these decomps + call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc) + + if (associated(this%latvals)) then + coord => this%latvals + else + coord_p => cam_grid_get_latvals(this%grid_id) + if (associated(coord_p)) then + coord => coord_p else - field_lens(1) = 0 - allocate(map(0)) - end if - file_lens(1) = this%global_lat_size - !! XXgoldyXX: Think about caching these decomps - call cam_pio_newdecomp(iodesc, file_lens, map, pio_double) + allocate(coord(0)) + end if + end if + vdesc => header_info%get_lat_varid() + call pio_write_darray(File, vdesc, iodesc, coord, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing latitude') + if (.not. associated(this%latmap)) then + deallocate(map) + nullify(map) + end if + if (.not. (associated(coord_p) .or. associated(this%latvals))) then + deallocate(coord) + nullify(coord) + end if + call pio_freedecomp(File, iodesc) - if (associated(this%latvals)) then - coord => this%latvals - else - coord_p => cam_grid_get_latvals(this%grid_id) - if (associated(coord_p)) then - coord => coord_p - else - allocate(coord(0)) - end if - end if - vdesc => header_info%get_lat_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr) - call cam_pio_handle_error(ierr, subname//': Error writing latitude') - if (.not. associated(this%latmap)) then - deallocate(map) - nullify(map) - end if - if (.not. (associated(coord_p) .or. associated(this%latvals))) then - deallocate(coord) - nullify(coord) - end if - call pio_freedecomp(File, iodesc) + end subroutine cam_grid_patch_write_vals - end subroutine cam_grid_patch_write_vals + integer function cam_grid_patch_get_grid_index(this) result(index) + ! Dummy argument + class(cam_grid_patch_t) :: this - integer function cam_grid_patch_get_grid_index(this) result(index) - ! Dummy argument - class(cam_grid_patch_t) :: this + ! Local variable + integer :: i - ! Local variable - integer :: i + index = -1 + ! Find the grid index associated with our grid_id which is a decomp + do i = 1, cam_grid_num_grids() + if (cam_grids(i)%id == this%grid_id) then + index = i + exit + end if + end do - index = -1 - ! Find the grid index associated with our grid_id which is a decomp - do i = 1, cam_grid_num_grids() - if (cam_grids(i)%id == this%grid_id) then - index = i - exit - end if - end do + end function cam_grid_patch_get_grid_index - end function cam_grid_patch_get_grid_index + subroutine cam_grid_patch_deallocate(this) + ! Dummy argument + class(cam_grid_patch_t) :: this - subroutine cam_grid_patch_deallocate(this) - ! Dummy argument - class(cam_grid_patch_t) :: this + if (associated(this%mask)) then + deallocate(this%mask) + nullify(this%mask) + end if - if (associated(this%mask)) then - deallocate(this%mask) - nullify(this%mask) - end if + end subroutine cam_grid_patch_deallocate - end subroutine cam_grid_patch_deallocate + integer function cam_grid_header_info_get_gridid(this) result(id) + ! Dummy argument + class(cam_grid_header_info_t) :: this - integer function cam_grid_header_info_get_gridid(this) result(id) - ! Dummy argument - class(cam_grid_header_info_t) :: this + id = this%grid_id - id = this%grid_id + end function cam_grid_header_info_get_gridid - end function cam_grid_header_info_get_gridid + subroutine cam_grid_header_info_set_gridid(this, id) + ! Dummy argument + class(cam_grid_header_info_t) :: this + integer, intent(in) :: id - subroutine cam_grid_header_info_set_gridid(this, id) - ! Dummy argument - class(cam_grid_header_info_t) :: this - integer, intent(in) :: id + this%grid_id = id - this%grid_id = id + end subroutine cam_grid_header_info_set_gridid - end subroutine cam_grid_header_info_set_gridid + subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) + ! Dummy arguments + class(cam_grid_header_info_t) :: this + integer, intent(in) :: hdim1 + integer, optional, intent(in) :: hdim2 - subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - integer, intent(in) :: hdim1 - integer, optional, intent(in) :: hdim2 + ! Local variables + integer :: hdsize - ! Local variables - integer :: hdsize - character(len=*), parameter :: subname = 'cam_grid_header_info_set_hdims' + if (present(hdim2)) then + hdsize = 2 + else + hdsize = 1 + end if - if (present(hdim2)) then - hdsize = 2 - else - hdsize = 1 + if (allocated(this%hdims)) then + ! This can happen, for instance on opening a new version of the file + if (size(this%hdims) /= hdsize) then + call endrun('cam_grid_header_info_set_hdims: hdims is wrong size') end if + else + allocate(this%hdims(hdsize)) + end if + this%hdims(1) = hdim1 + if (present(hdim2)) then + this%hdims(2) = hdim2 + end if - if (allocated(this%hdims)) then - ! This can happen, for instance on opening a new version of the file - if (size(this%hdims) /= hdsize) then - call endrun(subname//': hdims is wrong size') - end if - else - allocate(this%hdims(hdsize)) - end if - this%hdims(1) = hdim1 - if (present(hdim2)) then - this%hdims(2) = hdim2 - end if + end subroutine cam_grid_header_info_set_hdims - end subroutine cam_grid_header_info_set_hdims + integer function cam_grid_header_info_num_hdims(this) result(num) + ! Dummy argument + class(cam_grid_header_info_t) :: this - integer function cam_grid_header_info_num_hdims(this) result(num) - ! Dummy argument - class(cam_grid_header_info_t) :: this + if (allocated(this%hdims)) then + num = size(this%hdims) + else + num = 0 + end if - if (allocated(this%hdims)) then - num = size(this%hdims) - else - num = 0 - end if + end function cam_grid_header_info_num_hdims - end function cam_grid_header_info_num_hdims + integer function cam_grid_header_info_hdim(this, index) result(id) + ! Dummy arguments + class(cam_grid_header_info_t) :: this + integer, intent(in) :: index - integer function cam_grid_header_info_hdim(this, index) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - integer, intent(in) :: index - - ! Local variable - character(len=120) :: errormsg - - if (allocated(this%hdims)) then - if ((index >= 1) .and. (index <= size(this%hdims))) then - id = this%hdims(index) - else - write(errormsg, '(a,i0,a)') 'Index out of range, (',index,')' - call endrun('cam_grid_header_info_hdim: '//errormsg) - end if + ! Local variable + character(len=120) :: errormsg + + if (allocated(this%hdims)) then + if ((index >= 1) .and. (index <= size(this%hdims))) then + id = this%hdims(index) else - write(errormsg, '(a)') 'No hdims allocated' - call endrun('cam_grid_header_info_hdim: '//errormsg) + write(errormsg, '(a,i0,a)') 'Index out of range, (',index,')' + call endrun('cam_grid_header_info_hdim: '//errormsg) end if + else + write(errormsg, '(a)') 'No hdims allocated' + call endrun('cam_grid_header_info_hdim: '//errormsg) + end if - end function cam_grid_header_info_hdim + end function cam_grid_header_info_hdim - subroutine cam_grid_header_info_set_varids(this, lon_varid, lat_varid) + subroutine cam_grid_header_info_set_varids(this, lon_varid, lat_varid) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: lon_varid - type(var_desc_t), pointer :: lat_varid + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: lon_varid + type(var_desc_t), pointer :: lat_varid - if (associated(this%lon_varid)) then - deallocate(this%lon_varid) - nullify(this%lon_varid) - end if - this%lon_varid => lon_varid - if (associated(this%lat_varid)) then - deallocate(this%lat_varid) - nullify(this%lat_varid) - end if - this%lat_varid => lat_varid + if (associated(this%lon_varid)) then + deallocate(this%lon_varid) + nullify(this%lon_varid) + end if + this%lon_varid => lon_varid + if (associated(this%lat_varid)) then + deallocate(this%lat_varid) + nullify(this%lat_varid) + end if + this%lat_varid => lat_varid - end subroutine cam_grid_header_info_set_varids + end subroutine cam_grid_header_info_set_varids - function cam_grid_header_info_lon_varid(this) result(id) + function cam_grid_header_info_lon_varid(this) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: id + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: id - id => this%lon_varid + id => this%lon_varid - end function cam_grid_header_info_lon_varid + end function cam_grid_header_info_lon_varid - function cam_grid_header_info_lat_varid(this) result(id) + function cam_grid_header_info_lat_varid(this) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: id + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: id - id => this%lat_varid + id => this%lat_varid - end function cam_grid_header_info_lat_varid + end function cam_grid_header_info_lat_varid - subroutine cam_grid_header_info_deallocate(this) - ! Dummy argument - class(cam_grid_header_info_t) :: this + subroutine cam_grid_header_info_deallocate(this) + ! Dummy argument + class(cam_grid_header_info_t) :: this - this%grid_id = -1 - if (allocated(this%hdims)) then - deallocate(this%hdims) - end if - if (associated(this%lon_varid)) then - deallocate(this%lon_varid) - nullify(this%lon_varid) - end if - if (associated(this%lat_varid)) then - deallocate(this%lat_varid) - nullify(this%lat_varid) - end if + this%grid_id = -1 + if (allocated(this%hdims)) then + deallocate(this%hdims) + end if + if (associated(this%lon_varid)) then + deallocate(this%lon_varid) + nullify(this%lon_varid) + end if + if (associated(this%lat_varid)) then + deallocate(this%lat_varid) + nullify(this%lat_varid) + end if - end subroutine cam_grid_header_info_deallocate + end subroutine cam_grid_header_info_deallocate - end module cam_grid_support +end module cam_grid_support diff --git a/src/utils/string_utils.F90 b/src/utils/string_utils.F90 index 4f0d17eb..812a5f76 100644 --- a/src/utils/string_utils.F90 +++ b/src/utils/string_utils.F90 @@ -2,6 +2,8 @@ module string_utils use shr_string_mod, only: to_upper => shr_string_toUpper use shr_string_mod, only: to_lower => shr_string_toLower + use cam_logfile, only: iulog + use cam_abortutils, only: endrun implicit none private @@ -9,6 +11,8 @@ module string_utils ! Public interface methods public :: strlist_get_ind ! Gets the index of a given string in a list of strings + public :: date2yyyymmdd ! convert encoded date integer to "yyyy-mm-dd" format + public :: sec2hms ! convert integer seconds past midnight to "hh:mm:ss" format public :: increment_string ! increments a string public :: last_sig_char ! Position of last significant character in string public :: to_str ! convert integer to left justified string @@ -29,9 +33,6 @@ subroutine strlist_get_ind(strlist, str, ind, abort) ! allows returning control to caller when the string is not found. Default ! behavior is to call endrun when string is not found. - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - ! Arguments character(len=*), intent(in) :: strlist(:) ! list of strings character(len=*), intent(in) :: str ! string to search for @@ -68,6 +69,61 @@ end subroutine strlist_get_ind !========================================================================================= + character(len=10) function 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 endrun ('DATE2YYYYMMDD: negative date not allowed') + end if + + year = date / 10000 + month = (date - year*10000) / 100 + day = date - year*10000 - month*100 + + write(date2yyyymmdd,80) year, month, day + 80 format(i4.4,'-',i2.2,'-',i2.2) + + end function date2yyyymmdd + + !========================================================================================= + + character(len=8) function 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(iulog,*)'SEC2HMS: bad input seconds:', seconds + call endrun ('SEC2HMS: bad input seconds:') + end if + + hours = seconds / 3600 + minutes = (seconds - hours*3600) / 60 + secs = (seconds - hours*3600 - minutes*60) + + write(sec2hms,80) hours, minutes, secs + 80 format(i2.2,':',i2.2,':',i2.2) + + end function sec2hms + + !========================================================================================= + integer function increment_string(str, increment) !----------------------------------------------------------------------- ! ... Increment a string whose ending characters are digits. From 05ddd39e4a2cd2a8f68eeeafedd685b8d444d841 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 31 May 2024 15:59:10 -0600 Subject: [PATCH 15/79] move registry hist routines to new module; update precision logic --- src/control/cam_comp.F90 | 4 +-- src/data/generate_registry_data.py | 41 +++++++++++++++++++++++++++--- src/history/cam_hist_file.F90 | 29 +++++++++++++-------- src/history/cam_history.F90 | 17 ++++++++++--- 4 files changed, 71 insertions(+), 20 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index f8984405..01e8ffec 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -26,8 +26,8 @@ module cam_comp use camsrfexch, only: cam_out_t, cam_in_t use physics_types, only: phys_state, phys_tend - use physics_types, only: physics_types_history_init - use physics_types, only: physics_types_history_out + use physics_types_history, only: physics_types_history_init + use physics_types_history, only: physics_types_history_out use dyn_comp, only: dyn_import_t, dyn_export_t use perf_mod, only: t_barrierf, t_startf, t_stopf diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 817a895a..d52009eb 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -824,6 +824,7 @@ def write_tstep_init_routine(self, outfile, indent, def write_hist_init_routine(self, outfile, indent, ddt_str): """ + Write calls to history_add_field for registry variables """ my_ddt = self.is_ddt if my_ddt: @@ -852,6 +853,7 @@ def write_hist_init_routine(self, outfile, indent, ddt_str): def write_hist_out_routine(self, outfile, indent, ddt_str): """ + Write calls to history_out_field for registry variables """ my_ddt = self.is_ddt if my_ddt: @@ -1379,17 +1381,39 @@ def write_source(self, outdir, indent, logger, physconst_vars): outfile.write('!! public interfaces', 0) outfile.write(f'public :: {self.allocate_routine_name()}', 1) outfile.write(f'public :: {self.tstep_init_routine_name()}', 1) - outfile.write(f'public :: {self.hist_init_routine_name()}', 1) - outfile.write(f'public :: {self.hist_out_routine_name()}', 1) + #outfile.write(f'public :: {self.hist_init_routine_name()}', 1) + #outfile.write(f'public :: {self.hist_out_routine_name()}', 1) # end of module header outfile.end_module_header() outfile.write("", 0) # Write data management subroutines self.write_allocate_routine(outfile, physconst_vars) self.write_tstep_init_routine(outfile, physconst_vars) + + # end with + + def write_history_source(self, outdir, indent, logger, physconst_vars): + """Write out source code for the variables in this file""" + module_name = f"{self.name}_history" + ofilename = os.path.join(outdir, f"{module_name}.F90") + logger.info(f"Writing registry history source file, {module_name}.F90") + file_desc = f"Interfaces for registry source file, {module_name}" + with FortranWriter(ofilename, "w", file_desc, + module_name, indent=indent) as outfile: + outfile.write("", 0) + self.write_hist_use_statements(outfile) + outfile.write_preamble() + # Write data management subroutine declarations + outfile.write('', 0) + outfile.write('!! public interfaces', 0) + outfile.write(f'public :: {self.hist_init_routine_name()}', 1) + outfile.write(f'public :: {self.hist_out_routine_name()}', 1) + # end of module header + outfile.end_module_header() + outfile.write("", 0) + # Write data management subroutines self.write_hist_init_routine(outfile) self.write_hist_out_routine(outfile) - # end with def allocate_routine_name(self): @@ -1476,6 +1500,16 @@ def write_tstep_init_routine(self, outfile, physconst_vars): outfile.write('', 0) outfile.write(f'end subroutine {subname}', 1) + def write_hist_use_statements(self, outfile): + """ + Write the use statements for all variables and DDTs in self.name + """ + outfile.write('', 0) + for var in self.__var_dict.variable_list(): + outfile.write(f"use {self.name}, only: {var.local_name}", 1) + # end if + outfile.write('', 0) + def write_hist_init_routine(self, outfile): """ Write a subroutine to add all registry variables @@ -1757,6 +1791,7 @@ def write_registry_files(registry, dycore, config, outdir, src_mod, src_root, if file_.generate_code: file_.write_metadata(outdir, logger) file_.write_source(outdir, indent, logger, physconst_vars) + file_.write_history_source(outdir, indent, logger, physconst_vars) # end if # end for diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 6a67649e..a08947b1 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1162,11 +1162,7 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) end if end if end if - !if ((this%field_list(field_index)%buffers(1)%buffer_type() == 8) .or. restart) then - ! ncreal = pio_double - !else - ! ncreal = pio_real - !end if + ncreal = pio_real call this%field_list(field_index)%dimensions(mdims) mdimsize = size(mdims,1) @@ -1510,7 +1506,8 @@ subroutine config_write_field(this, field_index, split_file_index, restart) integer :: num_dims integer :: idx logical :: index_map(3) - real(REAL32), allocatable :: field_data(:,:) + real(REAL32), allocatable :: field_data_32(:,:) + real(REAL64), allocatable :: field_data_64(:,:) class(hist_buffer_t), pointer :: buff_ptr class(hist_buff_2dreal64_t), pointer :: buff_ptr_2d class(hist_buff_2dreal32_t), pointer :: buff_ptr_2d_32 @@ -1519,7 +1516,11 @@ subroutine config_write_field(this, field_index, split_file_index, restart) ! Shape on disk call this%field_list(field_index)%shape(field_shape) frank = size(field_shape) - allocate(field_data(field_shape(1), field_shape(2))) + if (this%precision() == 'REAL32') then + allocate(field_data_32(field_shape(1), field_shape(2))) + else + allocate(field_data_64(field_shape(1), field_shape(2))) + end if ! Shape of array call this%field_list(field_index)%dimensions(dimind) @@ -1546,9 +1547,15 @@ subroutine config_write_field(this, field_index, split_file_index, restart) varid = this%field_list(field_index)%varid(patch_idx) call pio_setframe(this%hist_files(split_file_index), varid, int(max(1,samples_on_file),kind=PIO_OFFSET_KIND)) buff_ptr => this%field_list(field_index)%buffers - call hist_buffer_norm_value(buff_ptr, field_data) - call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & - field_shape(1:frank), field_data, varid) + if (this%precision() == 'REAL32') then + call hist_buffer_norm_value(buff_ptr, field_data_32) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & + field_shape(1:frank), field_data_32, varid) + else + call hist_buffer_norm_value(buff_ptr, field_data_64) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & + field_shape(1:frank), field_data_64, varid) + end if end do end subroutine config_write_field @@ -1712,7 +1719,7 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & call endrun(subname//"ERROR, Invalid history file type, '"// & trim(hist_file_type)//"'", file=__FILE__, line=__LINE__) end select - ! Translat Date: Fri, 31 May 2024 17:51:57 -0600 Subject: [PATCH 16/79] add constituents handling for add and out fields --- src/data/generate_registry_data.py | 30 +++++++++++++++++++++++++----- src/data/registry.xml | 8 ++++++++ src/history/cam_history.F90 | 1 - 3 files changed, 33 insertions(+), 6 deletions(-) diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 012eb351..bae04b24 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -892,8 +892,18 @@ def write_hist_out_routine(self, outfile, indent, ddt_str): # end if else: if self.diagnostic_name: - outstr = f"call history_out_field('{self.diagnostic_name}', {ddt_str}{self.local_name}, size({ddt_str}{self.local_name}, 1))" - outfile.write(outstr, indent) + if self.is_constituent: + outfile.write('', 0) + outfile.write(f"call const_get_index('{self.standard_name}', const_index, abort=.false., warning=.false.)", indent) + outfile.write("if (const_index >= 0) then", indent) + outfile.write("const_data_ptr => cam_constituents_array()", indent+1) + outstr = f"call history_out_field('{self.diagnostic_name}', const_data_ptr(:,:,const_index), size(const_data_ptr, 1))" + outfile.write(outstr, indent+1) + outfile.write("end if", indent) + else: + outstr = f"call history_out_field('{self.diagnostic_name}', {ddt_str}{self.local_name}, size({ddt_str}{self.local_name}, 1))" + outfile.write(outstr, indent) + # end if # end if # end if @@ -1407,8 +1417,6 @@ def write_source(self, outdir, indent, logger, physconst_vars): outfile.write('!! public interfaces', 0) outfile.write(f'public :: {self.allocate_routine_name()}', 1) outfile.write(f'public :: {self.tstep_init_routine_name()}', 1) - #outfile.write(f'public :: {self.hist_init_routine_name()}', 1) - #outfile.write(f'public :: {self.hist_out_routine_name()}', 1) # end of module header outfile.end_module_header() outfile.write("", 0) @@ -1532,7 +1540,9 @@ def write_hist_use_statements(self, outfile): """ outfile.write('', 0) for var in self.__var_dict.variable_list(): - outfile.write(f"use {self.name}, only: {var.local_name}", 1) + if not var.is_constituent: + outfile.write(f"use {self.name}, only: {var.local_name}", 1) + # end fi # end if outfile.write('', 0) @@ -1565,10 +1575,20 @@ def write_hist_out_routine(self, outfile): outfile.write('', 0) outfile.write(f'subroutine {subname}()', 1) outfile.write('use cam_history, only: history_out_field', 2) + outfile.write('use cam_ccpp_cap, only: cam_constituents_array', 2) + outfile.write('use cam_ccpp_cap, only: cam_model_const_properties', 2) + outfile.write('use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t', 2) + outfile.write('use cam_constituents, only: const_get_index', 2) + outfile.write('use ccpp_kinds, only: kind_phys', 2) outfile.write('', 0) outfile.write('!! Local variables', 2) + outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_prop_ptr(:)', 2) + outfile.write('real(kind_phys), pointer :: const_data_ptr(:,:,:)', 2) + outfile.write('character(len=512) :: standard_name', 2) + outfile.write('integer :: const_index', 2) subn_str = f'character(len=*), parameter :: subname = "{subname}"' outfile.write(subn_str, 2) + outfile.write('',0) for var in self.__var_dict.variable_list(): var.write_hist_out_routine(outfile, 2, '') # end for diff --git a/src/data/registry.xml b/src/data/registry.xml index ca1d5d4f..c2401b44 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -385,25 +385,33 @@ standard_name="water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water" units="kg kg-1" type="real" constituent="true"> Water vapor mass mixing ratio with respect to moist air plus all airborne condensates + horizontal_dimension vertical_layer_dimension Q cnst_Q + Cloud water mass mixing ratio with respect to moist air plus all airborne condensates + horizontal_dimension vertical_layer_dimension CLDLIQ cnst_CLDLIQ + Cloud ice mass mixing ratio with respect to moist air plus all airborne condensates + horizontal_dimension vertical_layer_dimension CLDICE cnst_CLDICE + rain mass mixing ratio with respect to moist air plus all airborne condensates + horizontal_dimension vertical_layer_dimension RAINQM cnst_RAINQM + diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 6cf95a9c..f526a2bf 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -456,7 +456,6 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla use cam_grid_support, only: cam_grid_get_array_bounds use cam_history_support, only: lookup_hist_coord_indices use cam_history_support, only: hist_coord_find_levels, hist_coords - !use cam_ccpp_cap, only: cam_const_get_index character(len=*), intent(in) :: diagnostic_name character(len=*), intent(in) :: standard_name From bc7eba2351e6e56a365d33ac10698585a5601c56 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 3 Jun 2024 18:18:42 -0600 Subject: [PATCH 17/79] code cleanup; better error handling; use new buffer interfaces --- src/history/cam_hist_file.F90 | 370 ++++++++++++++-------------------- src/history/cam_history.F90 | 128 +++++++----- 2 files changed, 227 insertions(+), 271 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index a08947b1..6829d024 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -6,22 +6,13 @@ module cam_hist_file use ISO_FORTRAN_ENV, only: REAL64, REAL32 use pio, only: file_desc_t, var_desc_t - use cam_history_support, only: max_fldlen=>max_fieldname_len, fieldname_len + use cam_history_support, only: max_fldlen=>max_fieldname_len use cam_history_support, only: fieldname_suffix_len - use cam_history_support, only: interp_info_t, max_chars - use cam_logfile, only: iulog - use shr_kind_mod, only: r8 => shr_kind_r8, CS => SHR_KIND_CS, CL => SHR_KIND_CL - use shr_kind_mod, only: r4 => shr_kind_r4 + use cam_history_support, only: interp_info_t + use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL use hist_field, only: hist_field_info_t - use physics_grid, only: columns_on_task - use vert_coord, only: pver use hist_hash_table, only: hist_hash_table_t - use hist_hashable, only: hist_hashable_t use cam_grid_support, only: max_split_files - use cam_abortutils, only: endrun, check_allocate - use cam_logfile, only: iulog - use spmd_utils, only: masterproc - use perf_mod, only: t_startf, t_stopf implicit none private @@ -89,28 +80,11 @@ module cam_hist_file type(var_desc_t), private :: mdtid type(var_desc_t), private :: ndcurid type(var_desc_t), private :: nscurid - type(var_desc_t), private :: co2vmrid - type(var_desc_t), private :: ch4vmrid - type(var_desc_t), private :: n2ovmrid - type(var_desc_t), private :: f11vmrid - type(var_desc_t), private :: f12vmrid - type(var_desc_t), private :: sol_tsiid - type(var_desc_t), private :: f107id - type(var_desc_t), private :: f107aid - type(var_desc_t), private :: f107pid - type(var_desc_t), private :: kpid - type(var_desc_t), private :: apid - type(var_desc_t), private :: byimfid - type(var_desc_t), private :: bzimfid - type(var_desc_t), private :: swvelid - type(var_desc_t), private :: swdenid - type(var_desc_t), private :: colat_crit1_id - type(var_desc_t), private :: colat_crit2_id type(var_desc_t), private :: tsecid type(var_desc_t), private :: nstephid - ! Field lists + ! Field list type(hist_field_info_t), allocatable, private :: field_list(:) type(hist_hash_table_t), private :: field_list_hash_table contains @@ -155,18 +129,21 @@ module cam_hist_file ! ======================================================================== function config_filename(this) result(cfiles) - use cam_filenames, only: interpret_filename_spec + use cam_filenames, only: interpret_filename_spec + use cam_abortutils, only: check_allocate ! Dummy arguments class(hist_file_t), intent(in) :: this character(len=CL), allocatable :: cfiles(:) character(len=1) :: accum_types(max_split_files) - integer :: file_idx + integer :: file_idx, ierr + character(len=*), parameter :: subname = 'config_filename: ' accum_types(instantaneous_file_index) = 'i' accum_types(accumulated_file_index) = 'a' -! accum_types = (/ 'i', 'a' /) - allocate(cfiles(max_split_files)) + allocate(cfiles(max_split_files), stat=ierr) + call check_allocate(ierr, subname, 'cfiles', & + file=__FILE__, line=__LINE__-1) do file_idx = 1, size(cfiles, 1) cfiles(file_idx) = interpret_filename_spec(this%filename_spec, & @@ -179,18 +156,23 @@ end function config_filename ! ======================================================================== subroutine config_set_filenames(this) - use cam_filenames, only: interpret_filename_spec + use cam_filenames, only: interpret_filename_spec + use cam_abortutils, only: check_allocate ! Dummy argument class(hist_file_t), intent(inout) :: this character(len=1) :: accum_types(max_split_files) - integer :: file_idx + integer :: file_idx, ierr + character(len=*), parameter :: subname = 'config_set_filenames: ' if (allocated(this%file_names)) then return end if - accum_types = (/ 'i', 'a' /) - allocate(this%file_names(max_split_files)) + accum_types(instantaneous_file_index) = 'i' + accum_types(accumulated_file_index) = 'a' + allocate(this%file_names(max_split_files), stat=ierr) + call check_allocate(ierr, subname, 'this%file_names', & + file=__FILE__, line=__LINE__-1) do file_idx = 1, size(this%file_names, 1) this%file_names(file_idx) = interpret_filename_spec(this%filename_spec, & unit=this%volume, accum_type=accum_types(file_idx), & @@ -267,7 +249,7 @@ end function config_get_beg_time ! ======================================================================== function config_output_freq(this) result(out_freq) - use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_kind_mod, only: CS => SHR_KIND_CS use shr_string_mod, only: to_lower => shr_string_toLower ! Dummy arguments class(hist_file_t), intent(in) :: this @@ -296,7 +278,6 @@ end function config_output_freq ! ======================================================================== subroutine config_output_freq_separate(this, out_freq_mult, out_freq_type) - use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS use shr_string_mod, only: to_lower => shr_string_toLower ! Dummy arguments class(hist_file_t), intent(in) :: this @@ -410,9 +391,9 @@ subroutine config_configure(this, volume, out_prec, max_frames, & inst_fields, avg_fields, min_fields, max_fields, var_fields, & write_nstep0, interp_out, interp_nlat, interp_nlon, interp_grid, & interp_type, split_file) - use shr_kind_mod, only: CL=>SHR_KIND_CL use shr_string_mod, only: to_lower => shr_string_toLower use string_utils, only: parse_multiplier + use cam_abortutils, only: endrun, check_allocate ! Dummy arguments class(hist_file_t), intent(inout) :: this character(len=*), intent(in) :: volume @@ -486,8 +467,6 @@ subroutine config_configure(this, volume, out_prec, max_frames, & num_fields = count_array(inst_fields) + count_array(avg_fields) + & count_array(min_fields) + count_array(max_fields) + count_array(var_fields) -! num_fields = size(inst_fields, 1) + size(avg_fields, 1) + & -! size(min_fields, 1) + size(max_fields, 1) + size(var_fields, 1) allocate(this%field_names(num_fields), stat=ierr) call check_allocate(ierr, subname, 'this%field_names', & file=__FILE__, line=__LINE__-1) @@ -536,6 +515,7 @@ subroutine config_print_config(this) use string_utils, only: to_str use spmd_utils, only: masterproc use cam_logfile, only: iulog + use cam_abortutils, only: endrun ! Dummy argument class(hist_file_t), intent(in) :: this @@ -625,9 +605,14 @@ end subroutine config_set_end_time ! ======================================================================== subroutine config_set_up_fields(this, possible_field_list) - use hist_api, only: hist_new_field, hist_new_buffer - use cam_grid_support, only: cam_grid_num_grids - use hist_msg_handler, only: hist_have_error, hist_log_messages + use hist_api, only: hist_new_field, hist_new_buffer + use hist_hashable, only: hist_hashable_t + use cam_grid_support, only: cam_grid_num_grids + use hist_msg_handler, only: hist_have_error, hist_log_messages + use cam_history_support, only: max_chars + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use cam_abortutils, only: check_allocate ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -651,7 +636,9 @@ subroutine config_set_up_fields(this, possible_field_list) type(hist_log_messages) :: errors - allocate(possible_grids(cam_grid_num_grids() + 1)) + allocate(possible_grids(cam_grid_num_grids() + 1), stat=ierr) + call check_allocate(ierr, subname, 'possible_grids', & + file=__FILE__, line=__LINE__-1) possible_grids = -1 num_grids = 0 do idx = 1, size(this%field_names) @@ -676,7 +663,9 @@ subroutine config_set_up_fields(this, possible_field_list) field_shape, beg_dims=beg_dim, end_dims=end_dim) call hist_new_buffer(field_info, field_shape, & this%rl_kind, 1, this%accumulate_types(idx), 1, errors=errors) - call errors%output(iulog) + if (masterproc) then + call errors%output(iulog) + end if call hist_new_buffer(field_info, field_shape, & this%rl_kind, 1, this%accumulate_types(idx), 1) ! Add to field list array and hash table @@ -703,7 +692,9 @@ subroutine config_set_up_fields(this, possible_field_list) end if end do ! Finish set-up of grids for this volume - allocate(this%grids(num_grids)) + allocate(this%grids(num_grids), stat=ierr) + call check_allocate(ierr, subname, 'this%grids', & + file=__FILE__, line=__LINE__-1) do grid_idx = 1, num_grids this%grids(grid_idx) = possible_grids(grid_idx) end do @@ -713,6 +704,7 @@ end subroutine config_set_up_fields ! ======================================================================== subroutine config_find_in_field_list(this, diagnostic_name, field_info, errmsg) + use hist_hashable, only: hist_hashable_t ! Dummy arguments class(hist_file_t), intent(in) :: this character(len=*), intent(in) :: diagnostic_name @@ -766,6 +758,8 @@ end subroutine config_find_in_field_list !####################################################################### subroutine AvgflagToString(avgflag, time_op) + use cam_history_support, only: max_chars + use cam_abortutils, only: endrun ! Dummy arguments character(len=3), intent(in) :: avgflag ! averaging flag character(len=max_chars), intent(out) :: time_op ! time op (e.g. max) @@ -806,19 +800,19 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) use pio, only: pio_put_var use cam_pio_utils, only: cam_pio_createfile, cam_pio_def_var use cam_pio_utils, only: cam_pio_def_dim, cam_pio_handle_error - use shr_kind_mod, only: CL => SHR_KIND_CL use cam_grid_support, only: cam_grid_header_info_t, cam_grid_write_attr use cam_grid_support, only: cam_grid_write_var use cam_history_support, only: write_hist_coord_attrs use cam_history_support, only: write_hist_coord_vars + use cam_history_support, only: max_chars use time_manager, only: get_ref_date, timemgr_get_calendar_cf use time_manager, only: get_step_size use string_utils, only: date2yyyymmdd, sec2hms use cam_control_mod, only: caseid use cam_initfiles, only: ncdata, bnd_topo -! use solar_parms_data, only: solar_parms_on -! use solar_wind_data, only: solar_wind_on -! use epotential_params, only: epot_active + use cam_abortutils, only: check_allocate, endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc ! Define the metadata for the file(s) for this volume ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -842,11 +836,6 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) integer :: num_patches integer, allocatable :: mdims(:) - ! peverwhee - temporary flags - remove when enabled in CAM-SIMA - logical :: solar_parms_on ! temporary solar parms flag - logical :: solar_wind_on ! temporary solar wind flag - logical :: epot_active ! temporary epotential params flag - logical :: is_satfile logical :: is_initfile logical :: varid_set @@ -871,20 +860,17 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) integer, allocatable :: mdimids(:) character(len=*), parameter :: subname = 'config_define_file: ' - ! peverwhee - temporary flags - remove when enabled in SIMA - epot_active = .false. - solar_parms_on = .false. - solar_wind_on = .false. - is_initfile = (this%hfile_type == hfile_type_init_value) is_satfile = (this%hfile_type == hfile_type_sat_track) ! Log what we're doing - if (this%is_split_file()) then - write(iulog,*)'Opening netcdf history files ', trim(this%file_names(accumulated_file_index)), & - ' ', trim(this%file_names(instantaneous_file_index)) - else - write(iulog,*) 'Opening netcdf history file ', trim(this%file_names(instantaneous_file_index)) + if (masterproc) then + if (this%is_split_file()) then + write(iulog,*)'Opening netcdf history files ', trim(this%file_names(accumulated_file_index)), & + ' ', trim(this%file_names(instantaneous_file_index)) + else + write(iulog,*) 'Opening netcdf history file ', trim(this%file_names(instantaneous_file_index)) + end if end if amode = PIO_CLOBBER @@ -940,49 +926,73 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) call write_hist_coord_attrs(this%hist_files(split_file_index), bnddim, mdimids, restart) ! Define time variable ierr=pio_def_var (this%hist_files(split_file_index),'time',pio_double,(/timdim/),this%timeid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "time" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'long_name', 'time') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "time" variable') str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec) ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'units', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "units" attribtue to "time" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'calendar', trim(calendar)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "calendar" attribute to "time" variable') ! Define date variable - ierr=pio_def_var (this%hist_files(split_file_index),'date',pio_int,(/timdim/),this%dateid) + ierr=pio_def_var (this%hist_files(split_file_index),'date ',pio_int,(/timdim/),this%dateid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "date" variable') str = 'current date (YYYYMMDD)' ierr=pio_put_att (this%hist_files(split_file_index), this%dateid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "date" variable') ! Define datesec variable ierr=pio_def_var (this%hist_files(split_file_index),'datesec ',pio_int,(/timdim/), this%datesecid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "datesec" variable') str = 'current seconds of current date' ierr=pio_put_att (this%hist_files(split_file_index), this%datesecid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "datesec" variable') ! ! Character header information ! str = 'CF-1.0' ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'Conventions', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "Conventions" attribtue to file') ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'source', 'CAM') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "source" attribute to file') #if ( defined BFB_CAM_SCAM_IOP ) ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL,'CAM_GENERATED_FORCING','create SCAM IOP dataset') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "CAM_GENERATED_FORCING" attribute to file') #endif ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'case', caseid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "case" attribute to file') ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'logname',logname) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "logname" attribute to file') ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'host', host) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "host" attribute to file') ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'initial_file', ncdata) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "initial_file" attribute to file') ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'topography_file', bnd_topo) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "topography_file" attribute to file') if (len_trim(model_doi_url) > 0) then ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'model_doi_url', model_doi_url) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "model_doi_url" attribute to file') end if ierr=pio_put_att (this%hist_files(split_file_index), PIO_GLOBAL, 'time_period_freq', trim(time_per_freq)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "time_period_freq" attribute to file') + if (.not. is_satfile) then ! Define time_bounds variable ierr=pio_put_att (this%hist_files(split_file_index), this%timeid, 'bounds', 'time_bounds') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "bounds" attribute to file') ierr=pio_def_var (this%hist_files(split_file_index),'time_bounds',pio_double,(/bnddim,timdim/),this%tbndid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "time_bounds" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'long_name', 'time interval endpoints') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "time_bounds" variable') str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec) ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'units', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "units" attribute to "time_bounds" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%tbndid, 'calendar', trim(calendar)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "calendar" attribute to "time_bounds" variable') ! ! Character @@ -990,152 +1000,79 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) dimenchar(1) = chardim dimenchar(2) = timdim ierr=pio_def_var (this%hist_files(split_file_index),'date_written',pio_char,dimenchar,this%date_writtenid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "date_written" variable') ierr=pio_def_var (this%hist_files(split_file_index),'time_written',pio_char,dimenchar,this%time_writtenid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "time_written" variable') ! ! Integer header ! ! Define base day variables ierr=pio_def_var (this%hist_files(split_file_index),'ndbase',PIO_INT,this%ndbaseid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "ndbase" variable') str = 'base day' ierr=pio_put_att (this%hist_files(split_file_index), this%ndbaseid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "ndbase" variable') ierr=pio_def_var (this%hist_files(split_file_index),'nsbase',PIO_INT,this%nsbaseid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "nsbase" variable') str = 'seconds of base day' ierr=pio_put_att (this%hist_files(split_file_index), this%nsbaseid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "nsbase" variable') ierr=pio_def_var (this%hist_files(split_file_index),'nbdate',PIO_INT,this%nbdateid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "nbdate" variable') str = 'base date (YYYYMMDD)' ierr=pio_put_att (this%hist_files(split_file_index), this%nbdateid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribtue to "nbdate" variable') #if ( defined BFB_CAM_SCAM_IOP ) ierr=pio_def_var (this%hist_files(split_file_index),'bdate',PIO_INT,this%bdateid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "bdate" variable') str = 'base date (YYYYMMDD)' ierr=pio_put_att (this%hist_files(split_file_index), this%bdateid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "bdate" variable') #endif ierr=pio_def_var (this%hist_files(split_file_index),'nbsec',PIO_INT,this%nbsecid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "nbsec" variable') str = 'seconds of base date' ierr=pio_put_att (this%hist_files(split_file_index), this%nbsecid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "nbsec" variable') ierr=pio_def_var (this%hist_files(split_file_index),'mdt',PIO_INT,this%mdtid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "mdt" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%mdtid, 'long_name', 'timestep') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "mdt" variable') ierr=pio_put_att (this%hist_files(split_file_index), this%mdtid, 'units', 's') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "units" attribute to "mdt" variable') ! ! Create variables for model timing and header information ! if (split_file_index == instantaneous_file_index) then ierr=pio_def_var (this%hist_files(split_file_index),'ndcur ',pio_int,(/timdim/),this%ndcurid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "ndcur" variable') str = 'current day (from base day)' ierr=pio_put_att (this%hist_files(split_file_index), this%ndcurid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "ndcur" variable') ierr=pio_def_var (this%hist_files(split_file_index),'nscur ',pio_int,(/timdim/),this%nscurid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "nscur" variable') str = 'current seconds of current day' ierr=pio_put_att (this%hist_files(split_file_index), this%nscurid, 'long_name', trim(str)) - end if - - if (.not. is_initfile .and. split_file_index == instantaneous_file_index) then - ! Don't write the GHG/Solar forcing data to the IC file. - ! Only write the GHG/Solar forcing data to the instantaneous file - ierr=pio_def_var (this%hist_files(split_file_index),'co2vmr ',pio_double,(/timdim/),this%co2vmrid) - str = 'co2 volume mixing ratio' - ierr=pio_put_att (this%hist_files(split_file_index), this%co2vmrid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'ch4vmr ',pio_double,(/timdim/),this%ch4vmrid) - str = 'ch4 volume mixing ratio' - ierr=pio_put_att (this%hist_files(split_file_index), this%ch4vmrid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'n2ovmr ',pio_double,(/timdim/),this%n2ovmrid) - str = 'n2o volume mixing ratio' - ierr=pio_put_att (this%hist_files(split_file_index), this%n2ovmrid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'f11vmr ',pio_double,(/timdim/),this%f11vmrid) - str = 'f11 volume mixing ratio' - ierr=pio_put_att (this%hist_files(split_file_index), this%f11vmrid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'f12vmr ',pio_double,(/timdim/),this%f12vmrid) - str = 'f12 volume mixing ratio' - ierr=pio_put_att (this%hist_files(split_file_index), this%f12vmrid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'sol_tsi ',pio_double,(/timdim/),this%sol_tsiid) - str = 'total solar irradiance' - ierr=pio_put_att (this%hist_files(split_file_index), this%sol_tsiid, 'long_name', trim(str)) - str = 'W/m2' - ierr=pio_put_att (this%hist_files(split_file_index), this%sol_tsiid, 'units', trim(str)) - - if (solar_parms_on) then - ! solar / geomagnetic activity indices... - ierr=pio_def_var (this%hist_files(split_file_index),'f107',pio_double,(/timdim/),this%f107id) - str = '10.7 cm solar radio flux (F10.7)' - ierr=pio_put_att (this%hist_files(split_file_index), this%f107id, 'long_name', trim(str)) - str = '10^-22 W m^-2 Hz^-1' - ierr=pio_put_att (this%hist_files(split_file_index), this%f107id, 'units', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'f107a',pio_double,(/timdim/),this%f107aid) - str = '81-day centered mean of 10.7 cm solar radio flux (F10.7)' - ierr=pio_put_att (this%hist_files(split_file_index), this%f107aid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'f107p',pio_double,(/timdim/),this%f107pid) - str = 'Pervious day 10.7 cm solar radio flux (F10.7)' - ierr=pio_put_att (this%hist_files(split_file_index), this%f107pid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'kp',pio_double,(/timdim/),this%kpid) - str = 'Daily planetary K geomagnetic index' - ierr=pio_put_att (this%hist_files(split_file_index), this%kpid, 'long_name', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'ap',pio_double,(/timdim/),this%apid) - str = 'Daily planetary A geomagnetic index' - ierr=pio_put_att (this%hist_files(split_file_index), this%apid, 'long_name', trim(str)) - end if - - if (solar_wind_on) then - ierr=pio_def_var (this%hist_files(split_file_index),'byimf',pio_double,(/timdim/),this%byimfid) - str = 'Y component of the interplanetary magnetic field' - ierr=pio_put_att (this%hist_files(split_file_index), this%byimfid, 'long_name', trim(str)) - str = 'nT' - ierr=pio_put_att (this%hist_files(split_file_index), this%byimfid, 'units', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'bzimf',pio_double,(/timdim/),this%bzimfid) - str = 'Z component of the interplanetary magnetic field' - ierr=pio_put_att (this%hist_files(split_file_index), this%bzimfid, 'long_name', trim(str)) - str = 'nT' - ierr=pio_put_att (this%hist_files(split_file_index), this%bzimfid, 'units', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'swvel',pio_double,(/timdim/),this%swvelid) - str = 'Solar wind speed' - ierr=pio_put_att (this%hist_files(split_file_index), this%swvelid, 'long_name', trim(str)) - str = 'km/sec' - ierr=pio_put_att (this%hist_files(split_file_index), this%swvelid, 'units', trim(str)) - - ierr=pio_def_var (this%hist_files(split_file_index),'swden',pio_double,(/timdim/),this%swdenid) - str = 'Solar wind ion number density' - ierr=pio_put_att (this%hist_files(split_file_index), this%swdenid, 'long_name', trim(str)) - str = 'cm-3' - ierr=pio_put_att (this%hist_files(split_file_index), this%swdenid, 'units', trim(str)) - end if - - if (epot_active) then - ierr=pio_def_var (this%hist_files(split_file_index),'colat_crit1',pio_double,(/timdim/),this%colat_crit1_id) - ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit1_id, 'long_name', & - 'First co-latitude of electro-potential critical angle') - ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit1_id, 'units', 'degrees') - - ierr=pio_def_var (this%hist_files(split_file_index),'colat_crit2',pio_double,(/timdim/),this%colat_crit2_id) - ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit2_id, 'long_name', & - 'Second co-latitude of electro-potential critical angle') - ierr=pio_put_att (this%hist_files(split_file_index), this%colat_crit2_id, 'units', 'degrees') - end if - end if ! instantaneous, .not. initfile - - if (split_file_index == instantaneous_file_index) then + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "nscur" variable') #if ( defined BFB_CAM_SCAM_IOP ) ierr=pio_def_var (this%hist_files(split_file_index),'tsec ',pio_int,(/timdim/),this%tsecid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "tsec" variable') str = 'current seconds of current date needed for scam' ierr=pio_put_att (this%hist_files(split_file_index), this%tsecid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "tsec" variable') #endif ierr=pio_def_var (this%hist_files(split_file_index),'nsteph',pio_int,(/timdim/),this%nstephid) + call cam_pio_handle_error(ierr, 'config_define_file: failed to define "nsteph" variable') str = 'current timestep' ierr=pio_put_att (this%hist_files(split_file_index), this%nstephid, 'long_name', trim(str)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "nsteph" variable') end if end if ! .not. satfile @@ -1172,7 +1109,9 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) ! varid_set = .true. if(.not. this%field_list(field_index)%varid_set()) then - call this%field_list(field_index)%allocate_varid(num_patches) + call this%field_list(field_index)%allocate_varid(num_patches, ierr) + call check_allocate(ierr, subname, 'field '//trim(this%field_list(field_index)%diag_name())//' varid', & + file=__FILE__, line=__LINE__-1) varid_set = .false. end if ! Find appropriate grid in header_info @@ -1204,7 +1143,6 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) ! We have defined the horizontal grid dimensions in dimindex fdims = num_hdims do jdx = 1, mdimsize - write(iulog,*) 'adding an mdim' fdims = fdims + 1 dimids_tmp(fdims) = mdimids(mdims(jdx)) end do @@ -1340,6 +1278,10 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) use time_manager, only: set_date_from_time_float, get_step_size use datetime_mod, only: datetime use hist_api, only: hist_buffer_norm_value + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use cam_pio_utils, only: cam_pio_handle_error ! Dummy arguments class(hist_file_t), intent(inout) :: this integer, intent(in) :: volume_index @@ -1379,16 +1321,18 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) yr_mid, mon_mid, day_mid, ncsec(accumulated_file_index)) ncdate(accumulated_file_index) = yr_mid*10000 + mon_mid*100 + day_mid num_samples = this%num_samples - do split_file_index = 1, max_split_files - if (split_file_index == instantaneous_file_index) then - write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) - else if (this%split_file) then - write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) - end if -200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & - i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) - end do - write(iulog,*) + if (masterproc) then + do split_file_index = 1, max_split_files + if (split_file_index == instantaneous_file_index) then + write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) + else if (this%split_file) then + write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) + end if +200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & + i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + end do + write(iulog,*) + end if call this%increment_samples() is_initfile = (this%hfile_type == hfile_type_init_value) is_satfile = (this%hfile_type == hfile_type_sat_track) @@ -1396,12 +1340,16 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) start = num_samples count1 = 1 ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%ndcurid,(/start/),(/count1/),(/ndcur/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ndcur" variable') ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "nscur" variable') do split_file_index = 1, max_split_files if (pio_file_is_open(this%hist_files(split_file_index))) then ierr = pio_put_var (this%hist_files(split_file_index),this%dateid,(/start/),(/count1/),(/ncdate(split_file_index)/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ncdate" variable') ierr = pio_put_var (this%hist_files(split_file_index),this%datesecid,(/start/),(/count1/),(/ncsec(split_file_index)/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ncsec" variable') end if end do @@ -1413,11 +1361,13 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) do split_file_index = 1, max_split_files if (pio_file_is_open(tape(t)%Files(f))) then ierr = pio_put_var (this%hist_files(split_file_index),this%tsecid,(/start/),(/count1/),(/tsec/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "tsec" variable') end if end do #endif ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nstephid,(/start/),(/count1/),(/nstep/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "nstephid" variable') startc(1) = 1 startc(2) = start countc(1) = 2 @@ -1432,11 +1382,14 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) ierr=pio_put_var (this%hist_files(split_file_index), this%timeid, (/start/),(/count1/), & (/(time_interval(1) + time_interval(2)) / 2._r8/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write midpoint "time" variable') else ! not an accumulated history tape - time is current time ierr=pio_put_var (this%hist_files(split_file_index), this%timeid, (/start/),(/count1/),(/time/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write instantaneous "time" variable') end if ierr=pio_put_var (this%hist_files(split_file_index), this%tbndid, startc, countc, time_interval) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "time_bounds" variable') end do if(.not.restart) this%beg_time = time ! update beginning time of next interval @@ -1448,7 +1401,9 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) do split_file_index = 1, max_split_files if (pio_file_is_open(this%hist_files(split_file_index))) then ierr = pio_put_var (this%hist_files(split_file_index), this%date_writtenid, startc, countc, (/cdate/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "cdate" variable') ierr = pio_put_var (this%hist_files(split_file_index), this%time_writtenid, startc, countc, (/ctime/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ctime" variable') end if end do @@ -1481,9 +1436,10 @@ end subroutine config_write_time_dependent_variables subroutine config_write_field(this, field_index, split_file_index, restart) use pio, only: PIO_OFFSET_KIND, pio_setframe use cam_history_support, only: hist_coords - use hist_buffer, only: hist_buffer_t, hist_buff_2dreal64_t, hist_buff_2dreal32_t - use hist_api, only: hist_buffer_norm_value - use cam_grid_support, only: cam_grid_write_dist_array + use hist_buffer, only: hist_buffer_t + use hist_api, only: hist_buffer_norm_value + use cam_grid_support, only: cam_grid_write_dist_array + use cam_abortutils, only: check_allocate ! Dummy arguments class(hist_file_t), intent(inout) :: this integer, intent(in) :: field_index @@ -1493,40 +1449,34 @@ subroutine config_write_field(this, field_index, split_file_index, restart) ! Local variables integer, allocatable :: field_shape(:) ! Field file dim sizes integer :: frank ! Field file rank - !type(dim_index_2d) :: dimind2 ! 2-D dimension index - !type(dim_index_3d) :: dimind ! 3-D dimension index integer, allocatable :: dimind(:) integer, allocatable :: dim_sizes(:) integer, allocatable :: beg_dims(:) integer, allocatable :: end_dims(:) - integer :: patch_idx, num_patches + integer :: patch_idx, num_patches, ierr type(var_desc_t) :: varid integer :: samples_on_file integer :: field_decomp integer :: num_dims integer :: idx logical :: index_map(3) - real(REAL32), allocatable :: field_data_32(:,:) - real(REAL64), allocatable :: field_data_64(:,:) + real(r8), allocatable :: field_data(:,:) class(hist_buffer_t), pointer :: buff_ptr - class(hist_buff_2dreal64_t), pointer :: buff_ptr_2d - class(hist_buff_2dreal32_t), pointer :: buff_ptr_2d_32 + character(len=*), parameter :: subname = 'config_write_field: ' !!! Get the field's shape and decomposition ! Shape on disk call this%field_list(field_index)%shape(field_shape) frank = size(field_shape) - if (this%precision() == 'REAL32') then - allocate(field_data_32(field_shape(1), field_shape(2))) - else - allocate(field_data_64(field_shape(1), field_shape(2))) - end if + allocate(field_data(field_shape(1), field_shape(2)), stat=ierr) + call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) ! Shape of array call this%field_list(field_index)%dimensions(dimind) call this%field_list(field_index)%beg_dims(beg_dims) call this%field_list(field_index)%end_dims(end_dims) - allocate(dim_sizes(size(beg_dims))) + allocate(dim_sizes(size(beg_dims)), stat=ierr) + call check_allocate(ierr, subname, 'dim_sizes', file=__FILE__, line=__LINE__-1) do idx = 1, size(beg_dims) dim_sizes(idx) = end_dims(idx) - beg_dims(idx) + 1 end do @@ -1547,15 +1497,9 @@ subroutine config_write_field(this, field_index, split_file_index, restart) varid = this%field_list(field_index)%varid(patch_idx) call pio_setframe(this%hist_files(split_file_index), varid, int(max(1,samples_on_file),kind=PIO_OFFSET_KIND)) buff_ptr => this%field_list(field_index)%buffers - if (this%precision() == 'REAL32') then - call hist_buffer_norm_value(buff_ptr, field_data_32) - call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & - field_shape(1:frank), field_data_32, varid) - else - call hist_buffer_norm_value(buff_ptr, field_data_64) - call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & - field_shape(1:frank), field_data_64, varid) - end if + call hist_buffer_norm_value(buff_ptr, field_data) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & + field_shape(1:frank), field_data, varid) end do end subroutine config_write_field @@ -1565,6 +1509,8 @@ end subroutine config_write_field subroutine config_close_files(this) use pio, only: pio_file_is_open use cam_pio_utils, only: cam_pio_closefile + use spmd_utils, only: masterproc + use cam_logfile, only: iulog ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -1619,10 +1565,10 @@ end function count_array subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_avg_fields, hist_min_fields, hist_max_fields, hist_var_fields) use mpi, only: MPI_CHARACTER, MPI_INTEGER, MPI_LOGICAL - use shr_kind_mod, only: CL=>SHR_KIND_CL use string_utils, only: to_str use spmd_utils, only: masterproc, masterprocid, mpicom use shr_nl_mod, only: shr_nl_find_group_name + use cam_abortutils, only: endrun ! Read a history file configuration from and process it into ! . ! , , , , & @@ -1692,19 +1638,11 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & has_acc = .false. ! Read namelist entry if (masterproc) then -! rewind(unitn) -! call shr_nl_find_group_name(unitn, 'hist_file_config_nl', ierr) -! if (ierr == 0) then read(unitn, hist_file_config_nl, iostat=ierr) if (ierr /= 0) then call endrun(subname//"ERROR "//trim(to_str(ierr))// & " reading namelist", file=__FILE__, line=__LINE__) end if -! else -! write(iulog,*) ierr -! write(iulog, *) subname, ": WARNING, no hist_file_config_nl ", & -! "namelist found" -! end if ! Translate select case(trim(hist_file_type)) case(UNSET_C, 'history') @@ -1796,11 +1734,11 @@ end subroutine read_namelist_entry subroutine allocate_field_arrays(unitn, hist_inst_fields, & hist_avg_fields, hist_min_fields, hist_max_fields, hist_var_fields) use mpi, only: MPI_INTEGER - use shr_kind_mod, only: SHR_KIND_CL use shr_nl_mod, only: shr_nl_find_group_name use string_utils, only: to_str use cam_logfile, only: iulog use spmd_utils, only: mpicom, masterproc, masterprocid + use cam_abortutils, only: check_allocate, endrun ! Read the maximum sizes of field arrays from namelist file and allocate ! field arrays ! Dummy arguments @@ -1817,7 +1755,7 @@ subroutine allocate_field_arrays(unitn, hist_inst_fields, & integer :: hist_num_min_fields integer :: hist_num_max_fields integer :: hist_num_var_fields - character(len=SHR_KIND_CL) :: errmsg + character(len=CL) :: errmsg character(len=*), parameter :: subname = 'allocate_field_arrays' namelist /hist_config_arrays_nl/ hist_num_inst_fields, & @@ -1895,10 +1833,11 @@ end subroutine allocate_field_arrays subroutine hist_read_namelist_config(filename, config_arr) use mpi, only: MPI_CHARACTER, MPI_INTEGER - use shr_kind_mod, only: max_str =>SHR_KIND_CXX, SHR_KIND_CS, SHR_KIND_CL + use shr_kind_mod, only: max_str =>SHR_KIND_CXX use shr_nl_mod, only: shr_nl_find_group_name use spmd_utils, only: masterproc, masterprocid, mpicom use string_utils, only: to_str + use cam_abortutils, only: check_allocate, endrun ! Read all the history configuration namelist groups from ! and return an array of config objects ! Note: File operations are done on the root task with results @@ -1921,7 +1860,7 @@ subroutine hist_read_namelist_config(filename, config_arr) character(len=max_fldlen), allocatable :: hist_max_fields(:) character(len=max_fldlen), allocatable :: hist_var_fields(:) character(len=max_str) :: config_line - character(len=SHR_KIND_CL) :: errmsg + character(len=CL) :: errmsg character(len=*), parameter :: subname = 'read_config_file' ! Variables for reading a namelist entry @@ -2058,6 +1997,7 @@ subroutine hist_read_namelist_config(filename, config_arr) end subroutine hist_read_namelist_config character(len=max_fldlen) function strip_suffix (name) + use cam_history_support, only: fieldname_len ! !---------------------------------------------------------- ! diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index f526a2bf..82d84847 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -16,27 +16,11 @@ module cam_history ! cam_hist_write_history_files !----------------------------------------------------------------------- - use ISO_FORTRAN_ENV, only: REAL64, REAL32, INT32, INT64 - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX - use shr_sys_mod, only: shr_sys_flush - use perf_mod, only: t_startf, t_stopf - use spmd_utils, only: masterproc -! use cam_filenames, only: interpret_filename_spec - use cam_instance, only: inst_suffix -! use cam_initfiles, only: ncdata, bnd_topo - use cam_abortutils, only: endrun - use cam_logfile, only: iulog use cam_hist_file, only: hist_file_t - use cam_grid_support, only: max_split_files - use cam_hist_file, only: instantaneous_file_index, accumulated_file_index - use cam_hist_file, only: strip_suffix - use cam_history_support, only: pfiles, horiz_only - use cam_history_support, only: max_fldlen=>max_fieldname_len, max_chars, fieldname_len + use cam_history_support, only: pfiles use hist_field, only: hist_field_info_t use hist_hash_table, only: hist_hash_table_t - use hist_hashable, only: hist_hashable_t - use time_manager, only: get_nstep implicit none private @@ -137,7 +121,12 @@ end subroutine history_readnl !=========================================================================== subroutine history_write_files() - use time_manager, only: set_date_from_time_float + use time_manager, only: set_date_from_time_float, get_nstep + use cam_grid_support, only: max_split_files + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use shr_kind_mod, only: r8 => shr_kind_r8 character(len=cl) :: file_names(max_split_files) character(len=cl) :: prev_file_names(max_split_files) integer :: yr, mon, day @@ -219,17 +208,21 @@ subroutine history_write_files() do idx = 1, max_split_files if (prev_file_names(idx) == file_names(idx)) then duplicate = .true. - write(iulog,*)'hist_write_files: New filename same as old file = ', trim(file_names(idx)) + if (masterproc) then + write(iulog,*)'hist_write_files: New filename same as old file = ', trim(file_names(idx)) + end if end if end do end do if (duplicate) then filename_spec = hist_configs(file_idx)%get_filename_spec() prev_filename_spec = hist_configs(prev_file_idx)%get_filename_spec() - write(iulog,*)'Is there an error in your filename specifiers?' - write(iulog,*)'filename_spec(', file_idx, ') = ', trim(filename_spec) - if ( prev_file_idx /= file_idx )then - write(iulog,*)'filename_spec(', prev_file_idx, ') = ', trim(prev_filename_spec) + if (masterproc) then + write(iulog,*)'Is there an error in your filename specifiers?' + write(iulog,*)'filename_spec(', file_idx, ') = ', trim(filename_spec) + if ( prev_file_idx /= file_idx )then + write(iulog,*)'filename_spec(', prev_file_idx, ') = ', trim(prev_filename_spec) + end if end if call endrun('hist_write_files: ERROR - see atm log file for information') end if @@ -262,7 +255,7 @@ subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) use time_manager, only: get_prev_time, get_curr_time ! use cam_control_mod, only: restart_run, branch_run ! use sat_hist, only: sat_hist_init - use spmd_utils, only: mpicom, masterprocid + use spmd_utils, only: mpicom, masterprocid, masterproc use mpi, only: mpi_character ! !----------------------------------------------------------------------- @@ -338,8 +331,9 @@ end subroutine history_init_files !=========================================================================== subroutine print_field_list() + use cam_logfile, only: iulog + use spmd_utils, only: masterproc ! Local variables - class(hist_hashable_t), pointer :: field_ptr_value class(hist_field_info_t), pointer :: field_ptr character(len=4) :: avgflag @@ -400,7 +394,8 @@ end subroutine set_up_field_list_hash_table subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & avgflag, units, gridname) - use cam_history_support, only: get_hist_coord_index + use cam_history_support, only: get_hist_coord_index, max_chars, horiz_only + use cam_abortutils, only: endrun ! !----------------------------------------------------------------------- ! @@ -447,15 +442,18 @@ end subroutine history_add_field_1d subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgflag, & units, gridname, flag_xyfill) ! Add field to possible field linked list - use hist_api, only: hist_new_field - use hist_hashable, only: hist_hashable_char_t - use hist_hashable, only: hist_hashable_int_t - use cam_grid_support, only: cam_grid_get_coord_names - use cam_grid_support, only: cam_grid_dimensions - use cam_grid_support, only: cam_grid_id, cam_grid_is_zonal - use cam_grid_support, only: cam_grid_get_array_bounds + use hist_api, only: hist_new_field + use cam_grid_support, only: cam_grid_get_coord_names + use cam_grid_support, only: cam_grid_dimensions + use cam_grid_support, only: cam_grid_id, cam_grid_is_zonal + use cam_grid_support, only: cam_grid_get_array_bounds use cam_history_support, only: lookup_hist_coord_indices use cam_history_support, only: hist_coord_find_levels, hist_coords + use cam_history_support, only: max_fldlen=>max_fieldname_len, max_chars, fieldname_len + use cam_hist_file, only: strip_suffix + use cam_logfile, only: iulog + use cam_abortutils, only: endrun, check_allocate + use spmd_utils, only: masterproc character(len=*), intent(in) :: diagnostic_name character(len=*), intent(in) :: standard_name @@ -475,13 +473,14 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla integer, allocatable :: mdim_sizes(:) integer, allocatable :: field_shape(:) integer :: const_index - integer :: errcode + integer :: ierr integer :: dimbounds(2,2) character(len=512) :: errmsg character(len=max_fldlen) :: fname_tmp ! local copy of fname character(len=max_fldlen) :: coord_name ! for cell_methods character(len=max_fldlen) :: cell_methods character(len=3) :: mixing_ratio + character(len=*), parameter :: subname = 'history_add_field_nd: ' if (size(hist_configs) > 0 .and. hist_configs(1)%file_is_setup()) then call endrun ('history_add_field_nd: Attempt to add field '//trim(diagnostic_name)//' after history files set') @@ -502,9 +501,11 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla fname_tmp = strip_suffix(fname_tmp) if (len_trim(fname_tmp) > fieldname_len) then - write(iulog,*)'history_add_field_nd: field name cannot be longer than ', fieldname_len,' characters long' - write(iulog,*)'Field name: ',diagnostic_name - write(errmsg, *) 'Field name, "', trim(diagnostic_name), '" is too long' + if (masterproc) then + write(iulog,*)'history_add_field_nd: field name cannot be longer than ', fieldname_len,' characters long' + write(iulog,*)'Field name: ',diagnostic_name + write(errmsg, *) 'Field name, "', trim(diagnostic_name), '" is too long' + end if call endrun('history_add_field_nd: '//trim(errmsg)) end if @@ -552,7 +553,8 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla ! peverwhee - TODO: handle fill values - allocate(mdim_indices(size(dimnames, 1))) + allocate(mdim_indices(size(dimnames, 1)), stat=ierr) + call check_allocate(ierr, subname, 'mdim_indices', file=__FILE__, line=__LINE__-1) call lookup_hist_coord_indices(dimnames, mdim_indices) @@ -569,8 +571,10 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla if (size(mdim_indices) > 0) then rank = rank + size(mdim_indices) end if - allocate(field_shape(rank)) - allocate(mdim_sizes(size(mdim_indices))) + allocate(field_shape(rank), stat=ierr) + call check_allocate(ierr, subname, 'field_shape', file=__FILE__, line=__LINE__-1) + allocate(mdim_sizes(size(mdim_indices)), stat=ierr) + call check_allocate(ierr, subname, 'mdim_sizes', file=__FILE__, line=__LINE__-1) field_shape(1:pos) = grid_dims(1:pos) if (rank > pos) then do idx = 1, size(mdim_indices) @@ -610,8 +614,12 @@ end subroutine history_add_field_nd !=========================================================================== subroutine history_out_field_1d(diagnostic_name, field_values, idim) - use hist_api, only: hist_field_accumulate + use hist_api, only: hist_field_accumulate use hist_msg_handler, only: hist_log_messages + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name integer, intent(in) :: idim @@ -643,11 +651,9 @@ subroutine history_out_field_1d(diagnostic_name, field_values, idim) cycle end if ! Field is active on this file - accumulate! - ! Accumulate the field - if (hist_configs(file_idx)%precision() == 'REAL32') then - call hist_field_accumulate(field_info, real(field_values, REAL32), 1, logger=logger) - else - call hist_field_accumulate(field_info, real(field_values, REAL64), 1, logger=logger) + call hist_field_accumulate(field_info, field_values, 1, logger=logger) + if (masterproc) then + call logger%output(iulog) end if end do @@ -657,8 +663,12 @@ end subroutine history_out_field_1d !=========================================================================== subroutine history_out_field_2d(diagnostic_name, field_values, idim) - use hist_api, only: hist_field_accumulate + use hist_api, only: hist_field_accumulate use hist_msg_handler, only: hist_log_messages + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name integer, intent(in) :: idim @@ -690,13 +700,10 @@ subroutine history_out_field_2d(diagnostic_name, field_values, idim) cycle end if ! Field is active on this file - accumulate! - ! Accumulate the field - if (hist_configs(file_idx)%precision() == 'REAL32') then - call hist_field_accumulate(field_info, real(field_values, REAL32), 1, logger=logger) - else - call hist_field_accumulate(field_info, real(field_values, REAL64), 1, logger=logger) + call hist_field_accumulate(field_info, field_values, 1, logger=logger) + if (masterproc) then + call logger%output(iulog) end if - call logger%output(iulog) end do end subroutine history_out_field_2d @@ -704,7 +711,11 @@ end subroutine history_out_field_2d !=========================================================================== subroutine history_out_field_3d(diagnostic_name, field_values, idim) - use hist_api, only: hist_field_accumulate + use hist_api, only: hist_field_accumulate + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name integer, intent(in) :: idim @@ -735,8 +746,10 @@ subroutine history_out_field_3d(diagnostic_name, field_values, idim) cycle end if ! Field is active on this file - accumulate! - ! Accumulate the field !call hist_field_accumulate(field_info, real(field_values, REAL64), 1) + !if (masterproc) then + ! call logger%output(iulog) + !end if end do @@ -745,7 +758,10 @@ end subroutine history_out_field_3d !========================================================================== subroutine history_wrap_up(restart_write, last_timestep) - use time_manager, only: get_curr_date, get_curr_time + use time_manager, only: get_curr_date, get_curr_time, get_nstep + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use shr_kind_mod, only: r8 => shr_kind_r8 ! !----------------------------------------------------------------------- ! From 7baf682f23922cedae01c4f129d482adf532557d Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 4 Jun 2024 22:54:37 -0600 Subject: [PATCH 18/79] code cleanup; fix for indexing on multiple files --- src/history/cam_hist_file.F90 | 23 +--- src/history/cam_history.F90 | 210 ++++++++++++++-------------------- 2 files changed, 93 insertions(+), 140 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 6829d024..c2bec91f 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -109,7 +109,6 @@ module cam_hist_file procedure :: reset => config_reset procedure :: configure => config_configure procedure :: print_config => config_print_config - procedure :: increment_samples => config_increment_samples procedure :: set_beg_time => config_set_beg_time procedure :: set_end_time => config_set_end_time procedure :: set_filenames => config_set_filenames @@ -570,16 +569,6 @@ end subroutine config_print_config ! ======================================================================== - subroutine config_increment_samples(this) - ! Dummy argument - class(hist_file_t), intent(inout) :: this - - this%num_samples = this%num_samples + 1 - - end subroutine config_increment_samples - - ! ======================================================================== - subroutine config_set_beg_time(this, day, sec) ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -1333,12 +1322,14 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) end do write(iulog,*) end if - call this%increment_samples() + start = mod(num_samples, this%max_frames) + 1 + count1 = 1 + ! Increment samples + this%num_samples = this%num_samples + 1 + is_initfile = (this%hfile_type == hfile_type_init_value) is_satfile = (this%hfile_type == hfile_type_sat_track) num_samples = this%num_samples - start = num_samples - count1 = 1 ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%ndcurid,(/start/),(/count1/),(/ndcur/)) call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ndcur" variable') ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) @@ -1353,8 +1344,6 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) end if end do - ! peverwhee - TODO: GHG/solar forcing data on instantaneous file - #if ( defined BFB_CAM_SCAM_IOP ) dtime = get_step_size() tsec=dtime*nstep @@ -1386,7 +1375,7 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) else ! not an accumulated history tape - time is current time ierr=pio_put_var (this%hist_files(split_file_index), this%timeid, (/start/),(/count1/),(/time/)) - call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write instantaneous "time" variable') + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write instantaneous "time" variable') end if ierr=pio_put_var (this%hist_files(split_file_index), this%tbndid, startc, countc, time_interval) call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "time_bounds" variable') diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 82d84847..86f87959 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -3,17 +3,10 @@ module cam_history ! ! The cam_history module provides the user interface for CAM's history ! output capabilities. - ! It maintains the lists of fields that are written to each history file, - ! and the associated metadata for those fields such as descriptive names, - ! physical units, time axis properties, etc. ! - ! Public functions/subroutines: - ! cam_hist_init_files - ! cam_hist_write_history_state - ! cam_hist_write_restart - ! cam_hist_read_restart - ! cam_hist_capture_field - ! cam_hist_write_history_files + ! It maintains the list of possible fields and provides interfaces + ! to cam_hist_file hist_file_t object + ! !----------------------------------------------------------------------- use shr_kind_mod, only: cl=>SHR_KIND_CL, cxx=>SHR_KIND_CXX @@ -26,46 +19,19 @@ module cam_history private save - integer :: idx ! index for nhtfrq initialization character(len=cl) :: model_doi_url = '' ! Model DOI character(len=cl) :: caseid = '' ! case ID character(len=cl) :: ctitle = '' ! case title - ! NB: history_namelist value must match the group name in namelist_definition.xml - character(len=*), parameter :: history_namelist = 'cam_history_nl' - ! hrestpath: Full history restart pathnames - character(len=cxx) :: hrestpath(pfiles) = (/(' ',idx=1,pfiles)/) - character(len=cxx) :: cpath(pfiles) ! Array of current pathnames - character(len=cxx) :: nhfil(pfiles) ! Array of current file names - character(len=16) :: logname ! user name - character(len=16) :: host ! host name -!!XXgoldyXX: Change inithist to use same values as any other history file - character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or - ! 'YEARLY' then write IC file - -!!XXgoldyXX: Do we need maxvarmdims anymore? - integer, private :: maxvarmdims = 1 - ! - - integer :: lcltod_start(pfiles) ! start time of day for local time averaging (sec) - integer :: lcltod_stop(pfiles) ! stop time of day for local time averaging, stop > start is wrap around (sec) + character(len=16) :: logname ! user name + character(len=16) :: host ! host name ! Functions public :: history_readnl ! Namelist reader for CAM history -! public :: history_init_restart ! Write restart history data -! public :: history_write_restart ! Write restart history data -! public :: history_read_restart ! Read restart history data public :: history_write_files ! Write files out public :: history_init_files ! Initialization public :: history_add_field ! Write to list of possible history fields for this run public :: history_out_field ! Accumulate field if its in use by one or more tapes public :: history_wrap_up ! Process history files at end of timestep or run -! public :: history_finalize ! process history files at end of run -! public :: history_write_IC ! flag to dump of IC to IC file -! public :: history_define_fld ! Add a field to history file -! public :: history_capture_fld ! Capture current state of a model field -! public :: history_fld_active ! .true. if a field is active on any history file -! public :: history_fld_col_active ! .true. for each column where a field is active on any history file -! public :: register_vector_field ! Register vector field set for interpolated output interface history_out_field module procedure history_out_field_1d @@ -87,6 +53,11 @@ module cam_history CONTAINS subroutine history_readnl(nlfile) + !----------------------------------------------------------------------- + ! + ! Purpose: Read in history namelist and set hist_configs + ! + !----------------------------------------------------------------------- use spmd_utils, only: masterproc, masterprocid, mpicom use mpi, only: mpi_integer, mpi_logical, mpi_character use cam_hist_file, only: hist_read_namelist_config @@ -105,22 +76,17 @@ subroutine history_readnl(nlfile) ! Read in CAM history configuration call hist_read_namelist_config(nlfile, hist_configs) - ! Setup the interpolate_info structures - !do t = 1, size(interpolate_info) - ! interpolate_info(fil_idx)%interp_type = interpolate_type(fil_idx) - ! interpolate_info(fil_idx)%interp_gridtype = interpolate_gridtype(fil_idx) - ! interpolate_info(fil_idx)%interp_nlat = interpolate_nlat(fil_idx) - ! interpolate_info(fil_idx)%interp_nlon = interpolate_nlon(fil_idx) - !end do - - ! separate namelist reader for the satellite history file - !call sat_hist_readnl(nlfile, hfilename_spec, mfilt, fincl, hist_freq, avgflag_perfile) - end subroutine history_readnl !=========================================================================== subroutine history_write_files() + !----------------------------------------------------------------------- + ! + ! Purpose: Check if it's time to write any files and Write any active + ! fields to those files + ! + !----------------------------------------------------------------------- use time_manager, only: set_date_from_time_float, get_nstep use cam_grid_support, only: max_split_files use cam_logfile, only: iulog @@ -194,7 +160,7 @@ subroutine history_write_files() end if write_nstep0 = hist_configs(file_idx)%do_write_nstep0() if (nstep == 0 .and. .not. write_nstep0) then - ! Don't write the first step + ! Don't write the first nstep=0 sample cycle end if num_samples = hist_configs(file_idx)%get_num_samples() @@ -209,7 +175,7 @@ subroutine history_write_files() if (prev_file_names(idx) == file_names(idx)) then duplicate = .true. if (masterproc) then - write(iulog,*)'hist_write_files: New filename same as old file = ', trim(file_names(idx)) + write(iulog,*)'history_write_files: New filename same as old file = ', trim(file_names(idx)) end if end if end do @@ -224,10 +190,9 @@ subroutine history_write_files() write(iulog,*)'filename_spec(', prev_file_idx, ') = ', trim(prev_filename_spec) end if end if - call endrun('hist_write_files: ERROR - see atm log file for information') + call endrun('history_write_files: ERROR - see atm log file for information') end if call hist_configs(file_idx)%define_file(restart, logname, host, model_doi_url) - ! call hist_configs(file_idx)%write_time_dependent_variables(file_idx, restart) end if call hist_configs(file_idx)%write_time_dependent_variables(file_idx, restart) end do @@ -238,23 +203,13 @@ end subroutine history_write_files subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) - ! !----------------------------------------------------------------------- ! - ! Purpose: Initialize history file handler for initial or continuation - ! run. - ! For example, on an initial run, this routine initializes - ! the configured history files. On a restart run, this routine - ! only initializes history files declared beyond what existed - ! on the previous run. Files which already existed on the - ! previous run have already been initialized (i.e. named and - ! opened) in routine, hist_initialize_restart + ! Purpose: Print master field list and initialize history files ! !----------------------------------------------------------------------- use shr_sys_mod, only: shr_sys_getenv use time_manager, only: get_prev_time, get_curr_time -! use cam_control_mod, only: restart_run, branch_run -! use sat_hist, only: sat_hist_init use spmd_utils, only: mpicom, masterprocid, masterproc use mpi, only: mpi_character ! @@ -268,17 +223,9 @@ subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) ! ! Local workspace ! - integer :: fil_idx, fld_ind ! file, field indices - integer :: begdim1 ! on-node dim1 start index - integer :: enddim1 ! on-node dim1 end index - integer :: begdim2 ! on-node dim2 start index - integer :: enddim2 ! on-node dim2 end index - integer :: begdim3 ! on-node chunk or lat start index - integer :: enddim3 ! on-node chunk or lat end index + integer :: file_idx ! file, field indices integer :: day, sec ! day and seconds from base date integer :: rcode ! shr_sys_getenv return code -! type(master_entry), pointer :: listentry - character(len=32) :: fldname ! ! Save the DOI @@ -309,20 +256,15 @@ subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) call mpi_bcast(host, len(host), mpi_character, & masterprocid, mpicom, rcode) - ! peverwhee - override averaging flag if specified? + call get_curr_time(day, sec) ! elapased time since reference date -! if (branch_run) then -! call get_prev_time(day, sec) ! elapased time since reference date -! else - call get_curr_time(day, sec) ! elapased time since reference date -! end if - - do fil_idx = 1, size(hist_configs, 1) + ! Set up hist fields on each user-specified file + do file_idx = 1, size(hist_configs, 1) ! Time at beginning of current averaging interval. - call hist_configs(fil_idx)%set_beg_time(day, sec) + call hist_configs(file_idx)%set_beg_time(day, sec) ! Set up fields and buffers - call hist_configs(fil_idx)%set_up_fields(possible_field_list) + call hist_configs(file_idx)%set_up_fields(possible_field_list) end do @@ -331,6 +273,11 @@ end subroutine history_init_files !=========================================================================== subroutine print_field_list() + !----------------------------------------------------------------------- + ! + ! Purpose: Print master field list + ! + !----------------------------------------------------------------------- use cam_logfile, only: iulog use spmd_utils, only: masterproc ! Local variables @@ -371,6 +318,11 @@ end subroutine print_field_list !=========================================================================== subroutine set_up_field_list_hash_table() + !----------------------------------------------------------------------- + ! + ! Purpose: Populate field list hash table from linked list + ! + !----------------------------------------------------------------------- ! Local variables class(hist_field_info_t), pointer :: field_ptr @@ -393,17 +345,16 @@ end subroutine set_up_field_list_hash_table !=========================================================================== subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & - avgflag, units, gridname) + avgflag, units, gridname, flag_xyfill, mixing_ratio) use cam_history_support, only: get_hist_coord_index, max_chars, horiz_only use cam_abortutils, only: endrun - ! !----------------------------------------------------------------------- ! ! Purpose: Add a field to the master field list ! ! Method: Put input arguments of field name, units, number of levels, - ! averaging flag, and long name into a type entry in the global - ! master field list (masterlist). + ! averaging flag, and standard name into an entry in the global + ! field linked list (possible_field_list_head). ! !----------------------------------------------------------------------- @@ -416,6 +367,8 @@ subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & character(len=*), intent(in) :: avgflag ! averaging flag character(len=*), intent(in) :: units ! units of fname (max_chars) character(len=*), optional, intent(in) :: gridname + logical, optional, intent(in) :: flag_xyfill + character(len=*), optional, intent(in) :: mixing_ratio ! ! Local workspace @@ -433,15 +386,25 @@ subroutine history_add_field_1d(diagnostic_name, standard_name, vdim_name, & allocate(dimnames(1)) dimnames(1) = trim(vdim_name) end if - call history_add_field(diagnostic_name, standard_name, dimnames, avgflag, units, gridname) + call history_add_field(diagnostic_name, standard_name, dimnames, avgflag, units, & + gridname=gridname, flag_xyfill=flag_xyfill, mixing_ratio=mixing_ratio) end subroutine history_add_field_1d !=========================================================================== subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgflag, & - units, gridname, flag_xyfill) - ! Add field to possible field linked list + units, gridname, flag_xyfill, mixing_ratio) + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the master field list - generic; called from + ! history_add_field_1d + ! + ! Method: Put input arguments of field name, units, number of levels, + ! averaging flag, and standard name into an entry in the global + ! field linked list (possible_field_list_head). + ! + !----------------------------------------------------------------------- use hist_api, only: hist_new_field use cam_grid_support, only: cam_grid_get_coord_names use cam_grid_support, only: cam_grid_dimensions @@ -462,24 +425,24 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla character(len=*), intent(in) :: units ! units of fname (max_chars) character(len=*), optional, intent(in) :: gridname logical, optional, intent(in) :: flag_xyfill + character(len=*), optional, intent(in) :: mixing_ratio ! Local variables class(hist_field_info_t), pointer :: field_ptr class(hist_field_info_t), pointer :: listentry integer :: grid_decomp, rank, pos integer :: grid_dims(2) - integer :: dimcnt, num_levels + integer :: num_levels integer, allocatable :: mdim_indices(:) integer, allocatable :: mdim_sizes(:) integer, allocatable :: field_shape(:) - integer :: const_index - integer :: ierr + integer :: ierr, idx integer :: dimbounds(2,2) character(len=512) :: errmsg character(len=max_fldlen) :: fname_tmp ! local copy of fname character(len=max_fldlen) :: coord_name ! for cell_methods character(len=max_fldlen) :: cell_methods - character(len=3) :: mixing_ratio + character(len=3) :: mixing_ratio_loc character(len=*), parameter :: subname = 'history_add_field_nd: ' if (size(hist_configs) > 0 .and. hist_configs(1)%file_is_setup()) then @@ -498,7 +461,7 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla ! (strip "&IC" suffix if it exists) ! fname_tmp = diagnostic_name - fname_tmp = strip_suffix(fname_tmp) + fname_tmp = strip_suffix(fname_tmp) if (len_trim(fname_tmp) > fieldname_len) then if (masterproc) then @@ -517,19 +480,11 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla call endrun ('history_add_field_nd: '//diagnostic_name//' already on list') end if - ! If the field is an advected constituent determine whether its concentration - ! is based on dry or wet air. - ! peverwhee - TODO: constituents handling requires SIMA and/or framework update - !call cam_const_get_index(standard_name, const_index, errcode, errmsg) - !if (errcode /= 0) then - ! write(iulog,*) errmsg - ! call endrun('history_add_field_nd: '//diagnostic_name//' failed in const_get_index') - !end if - mixing_ratio = '' - !if (const_index > 0) then - ! mixing_ratio = cnst_get_type_byind(idx) - !end if - + if (present(mixing_ratio)) then + mixing_ratio_loc = mixing_ratio + else + mixing_ratio_loc = '' + end if if (present(gridname)) then grid_decomp = cam_grid_id(trim(gridname)) @@ -593,7 +548,7 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla else field_ptr%next => hist_new_field(diagnostic_name, & standard_name, standard_name, units, 'real', grid_decomp, & - mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio, & + mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio_loc, & dim_bounds=dimbounds, mdim_sizes=mdim_sizes, cell_methods=cell_methods, & flag_xyfill=flag_xyfill) exit @@ -602,7 +557,7 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla else possible_field_list_head => hist_new_field(diagnostic_name, & standard_name, standard_name, units, 'real', grid_decomp, & - mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio, & + mdim_indices, avgflag, num_levels, field_shape, mixing_ratio=mixing_ratio_loc, & dim_bounds=dimbounds, mdim_sizes=mdim_sizes, cell_methods=cell_methods, & flag_xyfill=flag_xyfill) end if @@ -614,6 +569,11 @@ end subroutine history_add_field_nd !=========================================================================== subroutine history_out_field_1d(diagnostic_name, field_values, idim) + !----------------------------------------------------------------------- + ! + ! Purpose: Accumulate active fields - 1d fields + ! + !----------------------------------------------------------------------- use hist_api, only: hist_field_accumulate use hist_msg_handler, only: hist_log_messages use cam_logfile, only: iulog @@ -636,10 +596,6 @@ subroutine history_out_field_1d(diagnostic_name, field_values, idim) errmsg = '' - ! peverwhee - TODO - ! - fill values - ! - different dimensions - do file_idx = 1, size(hist_configs, 1) ! Check if the field is on the current file call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) @@ -663,6 +619,11 @@ end subroutine history_out_field_1d !=========================================================================== subroutine history_out_field_2d(diagnostic_name, field_values, idim) + !----------------------------------------------------------------------- + ! + ! Purpose: Accumulate active fields - 2d fields + ! + !----------------------------------------------------------------------- use hist_api, only: hist_field_accumulate use hist_msg_handler, only: hist_log_messages use cam_logfile, only: iulog @@ -685,10 +646,6 @@ subroutine history_out_field_2d(diagnostic_name, field_values, idim) errmsg = '' - ! peverwhee - TODO - ! - fill values - ! - different dimensions - do file_idx = 1, size(hist_configs, 1) ! Check if the field is on the current file call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) @@ -711,6 +668,11 @@ end subroutine history_out_field_2d !=========================================================================== subroutine history_out_field_3d(diagnostic_name, field_values, idim) + !----------------------------------------------------------------------- + ! + ! Purpose: Accumulate active fields - 3d fields + ! + !----------------------------------------------------------------------- use hist_api, only: hist_field_accumulate use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -731,10 +693,6 @@ subroutine history_out_field_3d(diagnostic_name, field_values, idim) errmsg = '' - ! peverwhee - TODO - ! - fill values - ! - different dimensions - do file_idx = 1, size(hist_configs, 1) ! Check if the field is on the current file call hist_configs(file_idx)%find_in_field_list(diagnostic_name, field_info, errmsg) @@ -758,6 +716,12 @@ end subroutine history_out_field_3d !========================================================================== subroutine history_wrap_up(restart_write, last_timestep) + !----------------------------------------------------------------------- + ! + ! Purpose: Close files we're done with (either last timestep + ! or we've reached the max_frames cap for the file) + ! + !----------------------------------------------------------------------- use time_manager, only: get_curr_date, get_curr_time, get_nstep use cam_logfile, only: iulog use spmd_utils, only: masterproc From c1acda89fcf2d4ba7d81e621b222a923aa674d18 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Thu, 6 Jun 2024 11:19:03 -0600 Subject: [PATCH 19/79] fix and add hist_config tests --- cime_config/hist_config.py | 2 +- src/cpl/nuopc/atm_comp_nuopc.F90 | 4 +- src/data/generate_registry_data.py | 41 ++++++++++--- src/history/cam_hist_file.F90 | 21 ++++--- test/run_tests.sh | 2 + .../hist_config_files/atm_in_flat | 61 ++++++++++--------- .../hist_config_files/atm_in_multi | 40 ++++++------ .../hist_config_files/user_nl_cam_multi | 1 + 8 files changed, 103 insertions(+), 69 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 11865786..c274685f 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -434,7 +434,7 @@ class HistConfigEntry(): """ __HIST_CONF_ENTRY_RE = re.compile(r"[a-z][a-z_0]*") - __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:][ ]*(.*)$" + __HIST_VOL = r"(?:[ ]*;[ ]*((?:h[0-9]*)|i))?[ ]*[:=][ ]*(.*)$" def __init__(self, entry_string, entry_check_fn, process_fn): """Set the entry string regular expression and value check function diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 1374b1ad..17b17694 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -73,6 +73,7 @@ module atm_comp_nuopc use pio, only: pio_read_darray, pio_write_darray, pio_def_var, pio_inq_varid use pio, only: pio_noerr, pio_bcast_error, pio_internal_error, pio_seterrorhandling use pio, only: pio_def_var, pio_put_var, PIO_INT, PIO_OFFSET_KIND + use cam_history_support, only: fillvalue !$use omp_lib, only: omp_set_num_threads implicit none @@ -130,9 +131,6 @@ module atm_comp_nuopc character(len=*), parameter :: orb_variable_year = 'variable_year' character(len=*), parameter :: orb_fixed_parameters = 'fixed_parameters' - !Remove once history output is developed for CAMDEN -JN: - real(r8) :: fillvalue = 9.87e36_r8 - real(R8), parameter :: grid_tol = 1.e-2_r8 ! tolerance for calculated lat/lon vs read in integer :: local_iulog = 6 !Local iulog for use with NUOPC interfaces diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index bae04b24..4674a118 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -864,16 +864,33 @@ def write_hist_init_routine(self, outfile, indent, ddt_str): else: if self.diagnostic_name: if 'vertical_layer_dimension' in self.dimensions: - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"'lev', 'avg', '{self.units}')" + vertical_dim_str = "'lev'" elif 'vertical_interface_dimension' in self.dimensions: - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"'ilev', 'avg', '{self.units}')" + vertical_dim_str = "'ilev'" else: - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"horiz_only, 'avg', '{self.units}')" + vertical_dim_str = "horiz_only" # endif - outfile.write(outstr, indent) + if self.is_constituent: + outfile.write('', 0) + outfile.write(f"call const_get_index('{self.standard_name}', const_index, abort=.false., warning=.false.)", indent) + outfile.write("if (const_index >= 0) then", indent) + outfile.write("const_props_ptr => cam_model_const_properties()", indent+1) + outfile.write("call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg)", indent + 1) + outfile.write("if (const_is_dry) then", indent + 1) + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"{vertical_dim_str}, 'avg', '{self.units}', mixing_ratio='dry')" + outfile.write(outstr, indent + 2) + outfile.write("else", indent + 1) + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"{vertical_dim_str}, 'avg', '{self.units}', mixing_ratio='wet')" + outfile.write(outstr, indent + 2) + outfile.write("end if", indent + 1) + outfile.write("end if", indent) + else: + outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ + f"{vertical_dim_str}, 'avg', '{self.units}')" + outfile.write(outstr, indent) + # end if # end if # end if @@ -1556,8 +1573,16 @@ def write_hist_init_routine(self, outfile): outfile.write(f'subroutine {subname}()', 1) outfile.write('use cam_history, only: history_add_field', 2) outfile.write('use cam_history_support, only: horiz_only', 2) + outfile.write('use cam_ccpp_cap, only: cam_model_const_properties', 2) + outfile.write('use cam_constituents, only: const_get_index', 2) + outfile.write('use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t', 2) outfile.write('', 0) outfile.write('!! Local variables', 2) + outfile.write('integer :: const_index', 2) + outfile.write('integer :: errcode', 2) + outfile.write('logical :: const_is_dry', 2) + outfile.write('character(len=256) :: errmsg', 2) + outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:)', 2) subn_str = f'character(len=*), parameter :: subname = "{subname}"' outfile.write(subn_str, 2) for var in self.__var_dict.variable_list(): @@ -1576,13 +1601,11 @@ def write_hist_out_routine(self, outfile): outfile.write(f'subroutine {subname}()', 1) outfile.write('use cam_history, only: history_out_field', 2) outfile.write('use cam_ccpp_cap, only: cam_constituents_array', 2) - outfile.write('use cam_ccpp_cap, only: cam_model_const_properties', 2) outfile.write('use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t', 2) outfile.write('use cam_constituents, only: const_get_index', 2) outfile.write('use ccpp_kinds, only: kind_phys', 2) outfile.write('', 0) outfile.write('!! Local variables', 2) - outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_prop_ptr(:)', 2) outfile.write('real(kind_phys), pointer :: const_data_ptr(:,:,:)', 2) outfile.write('character(len=512) :: standard_name', 2) outfile.write('integer :: const_index', 2) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index c2bec91f..699a5e90 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -649,7 +649,8 @@ subroutine config_set_up_fields(this, possible_field_list) field_ptr%standard_name(), field_ptr%long_name(), & field_ptr%units(), field_ptr%type(), field_ptr%decomp(), & dimensions, this%accumulate_types(idx), field_ptr%num_levels(), & - field_shape, beg_dims=beg_dim, end_dims=end_dim) + field_shape, beg_dims=beg_dim, end_dims=end_dim, & + mixing_ratio=field_ptr%mixing_ratio()) call hist_new_buffer(field_info, field_shape, & this%rl_kind, 1, this%accumulate_types(idx), 1, errors=errors) if (masterproc) then @@ -1089,7 +1090,11 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) end if end if - ncreal = pio_real + if (this%precision() == 'real32') then + ncreal = pio_real + else + ncreal = pio_double + end if call this%field_list(field_index)%dimensions(mdims) mdimsize = size(mdims,1) fname_tmp = strip_suffix(this%field_list(field_index)%diag_name()) @@ -1329,7 +1334,7 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) is_initfile = (this%hfile_type == hfile_type_init_value) is_satfile = (this%hfile_type == hfile_type_sat_track) - num_samples = this%num_samples + ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%ndcurid,(/start/),(/count1/),(/ndcur/)) call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ndcur" variable') ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) @@ -1413,7 +1418,7 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) split_file_index == instantaneous_file_index .and. .not. restart) then cycle end if - call this%write_field(field_idx, split_file_index, restart) + call this%write_field(field_idx, split_file_index, restart, start) end do end do call t_stopf ('write_field') @@ -1422,7 +1427,8 @@ end subroutine config_write_time_dependent_variables ! ======================================================================== - subroutine config_write_field(this, field_index, split_file_index, restart) + subroutine config_write_field(this, field_index, split_file_index, restart, & + sample_index) use pio, only: PIO_OFFSET_KIND, pio_setframe use cam_history_support, only: hist_coords use hist_buffer, only: hist_buffer_t @@ -1434,6 +1440,7 @@ subroutine config_write_field(this, field_index, split_file_index, restart) integer, intent(in) :: field_index integer, intent(in) :: split_file_index logical, intent(in) :: restart + integer, intent(in) :: sample_index ! Local variables integer, allocatable :: field_shape(:) ! Field file dim sizes @@ -1444,7 +1451,6 @@ subroutine config_write_field(this, field_index, split_file_index, restart) integer, allocatable :: end_dims(:) integer :: patch_idx, num_patches, ierr type(var_desc_t) :: varid - integer :: samples_on_file integer :: field_decomp integer :: num_dims integer :: idx @@ -1480,11 +1486,10 @@ subroutine config_write_field(this, field_index, split_file_index, restart) field_decomp = this%field_list(field_index)%decomp() num_patches = 1 - samples_on_file = mod(this%num_samples, this%max_frames) do patch_idx = 1, num_patches varid = this%field_list(field_index)%varid(patch_idx) - call pio_setframe(this%hist_files(split_file_index), varid, int(max(1,samples_on_file),kind=PIO_OFFSET_KIND)) + call pio_setframe(this%hist_files(split_file_index), varid, int(sample_index,kind=PIO_OFFSET_KIND)) buff_ptr => this%field_list(field_index)%buffers call hist_buffer_norm_value(buff_ptr, field_data) call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & diff --git a/test/run_tests.sh b/test/run_tests.sh index 8d30fc25..874d72d8 100755 --- a/test/run_tests.sh +++ b/test/run_tests.sh @@ -80,6 +80,8 @@ run_unittest test/unit/test_create_readnl_files.py run_unittest test/unit/test_write_init_files.py # ParamGen atm_in namelist writer unit tests: run_unittest test/unit/test_atm_in_paramgen.py +# CAM history config unit tests +run_unittest test/unit/test_hist_config.py # Report if [ ${NUMERRORS} -gt 0 ]; then diff --git a/test/unit/sample_files/hist_config_files/atm_in_flat b/test/unit/sample_files/hist_config_files/atm_in_flat index 225968bd..0b0e6884 100644 --- a/test/unit/sample_files/hist_config_files/atm_in_flat +++ b/test/unit/sample_files/hist_config_files/atm_in_flat @@ -1,41 +1,44 @@ &hist_config_arrays_nl - hist_num_inst_fields = 3 - hist_num_avg_fields = 3 - hist_num_min_fields = 3 - hist_num_max_fields = 2 - hist_num_var_fields = 2 + hist_num_inst_fields = 3 + hist_num_avg_fields = 3 + hist_num_min_fields = 3 + hist_num_max_fields = 2 + hist_num_var_fields = 2 / &hist_file_config_nl - hist_volume = 'h1' - hist_avg_fields = 'MOE ', 'LARRY', 'CURLY' - hist_min_fields = 'mouse', 'bin ', 'gin ' - hist_max_fields = 'Skirt', 'Mad ' - hist_var_fields = 'std', 'stp' - hist_max_frames = 30 - hist_output_frequency = '14*hours' - hist_precision = 'REAL32' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_volume = 'h1' + hist_avg_fields = 'MOE ', 'LARRY', 'CURLY' + hist_min_fields = 'mouse', 'bin ', 'gin ' + hist_max_fields = 'Skirt', 'Mad ' + hist_var_fields = 'std', 'stp' + hist_max_frames = 30 + hist_output_frequency = '14*hours' + hist_precision = 'REAL32' + hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_write_nstep0 = .false. / &hist_file_config_nl - hist_volume = 'h3' - hist_inst_fields = 'T', 'U', 'V' - hist_max_frames = 24 - hist_output_frequency = '2*nsteps' - hist_precision = 'REAL64' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_volume = 'h3' + hist_inst_fields = 'T', 'U', 'V' + hist_max_frames = 24 + hist_output_frequency = '2*nsteps' + hist_precision = 'REAL64' + hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_write_nstep0 = .false. / &hist_file_config_nl - hist_volume = 'i' - hist_inst_fields = 'X' - hist_max_frames = 1 - hist_output_frequency = '2*nmonths' - hist_precision = 'REAL64' - hist_file_type = 'initial_value' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_volume = 'i' + hist_inst_fields = 'X' + hist_max_frames = 1 + hist_output_frequency = '2*nmonths' + hist_precision = 'REAL64' + hist_file_type = 'initial_value' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_write_nstep0 = .false. / diff --git a/test/unit/sample_files/hist_config_files/atm_in_multi b/test/unit/sample_files/hist_config_files/atm_in_multi index b62173d6..d9d859c9 100644 --- a/test/unit/sample_files/hist_config_files/atm_in_multi +++ b/test/unit/sample_files/hist_config_files/atm_in_multi @@ -1,15 +1,15 @@ &hist_config_arrays_nl - hist_num_inst_fields = 3 - hist_num_avg_fields = 258 - hist_num_min_fields = 0 - hist_num_max_fields = 0 - hist_num_var_fields = 0 + hist_num_inst_fields = 3 + hist_num_avg_fields = 258 + hist_num_min_fields = 0 + hist_num_max_fields = 0 + hist_num_var_fields = 0 / &hist_file_config_nl - hist_volume = 'h0' - hist_avg_fields = 'SOLIN ', 'SOLIN_d1 ', 'SOLIN_d2 ', 'SOLIN_d3 ', 'SOLIN_d4 ', 'SOLIN_d5 ', + hist_volume = 'h0' + hist_avg_fields = 'SOLIN ', 'SOLIN_d1 ', 'SOLIN_d2 ', 'SOLIN_d3 ', 'SOLIN_d4 ', 'SOLIN_d5 ', 'SOLIN_d6 ', 'SOLIN_d7 ', 'SOLIN_d8 ', 'SOLIN_d9 ', 'SOLIN_d10 ', 'QRS ', 'QRS_d1 ', 'QRS_d2 ', 'QRS_d3 ', 'QRS_d4 ', 'QRS_d5 ', 'QRS_d6 ', 'QRS_d7 ', 'QRS_d8 ', 'QRS_d9 ', 'QRS_d10 ', 'FSNT ', 'FSNT_d1 ', @@ -52,19 +52,21 @@ 'FLNSC_d9 ', 'FLNSC_d10 ', 'FLDS ', 'FLDS_d1 ', 'FLDS_d2 ', 'FLDS_d3 ', 'FLDS_d4 ', 'FLDS_d5 ', 'FLDS_d6 ', 'FLDS_d7 ', 'FLDS_d8 ', 'FLDS_d9 ', 'FLDS_d10 ', 'AODDUST1 ', 'AODDUST3 ', 'AODDUST ', 'AODVIS ', 'CCN3 ' - hist_max_frames = 1 - hist_output_frequency = '1*monthly' - hist_precision = 'REAL32' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_max_frames = 1 + hist_output_frequency = '1*monthly' + hist_precision = 'REAL32' + hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_write_nstep0 = .false. / &hist_file_config_nl - hist_volume = 'h3' - hist_inst_fields = 'T', 'U', 'V' - hist_max_frames = 24 - hist_output_frequency = '2*nsteps' - hist_precision = 'REAL64' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_volume = 'h3' + hist_inst_fields = 'T', 'U', 'V' + hist_max_frames = 24 + hist_output_frequency = '2*nsteps' + hist_precision = 'REAL64' + hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' + hist_write_nstep0 = .true. / diff --git a/test/unit/sample_files/hist_config_files/user_nl_cam_multi b/test/unit/sample_files/hist_config_files/user_nl_cam_multi index 8e9feec3..11b125eb 100644 --- a/test/unit/sample_files/hist_config_files/user_nl_cam_multi +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_multi @@ -15,3 +15,4 @@ hist_add_inst_fields;h3: T, U, V hist_output_frequency;h3: 2*nsteps hist_precision;h3: REAL64 hist_max_frames;h3: 24 +hist_write_nstep0;h3 = .true. From 510ade6e28f94f3b1f537878d116adf8dbc9634d Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Thu, 6 Jun 2024 13:28:48 -0600 Subject: [PATCH 20/79] add test for ic_names dictionary --- .../write_init_files/phys_vars_init_check_ddt_array.F90 | 8 ++++---- test/unit/test_write_init_files.py | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/test/unit/sample_files/write_init_files/phys_vars_init_check_ddt_array.F90 b/test/unit/sample_files/write_init_files/phys_vars_init_check_ddt_array.F90 index acb20531..b8053aeb 100644 --- a/test/unit/sample_files/write_init_files/phys_vars_init_check_ddt_array.F90 +++ b/test/unit/sample_files/write_init_files/phys_vars_init_check_ddt_array.F90 @@ -40,7 +40,7 @@ module phys_vars_init_check_ddt_array integer, public, parameter :: std_name_len = 25 ! Max length of input (IC) file variable names: - integer, public, parameter :: ic_name_len = 39 + integer, public, parameter :: ic_name_len = 12 ! Physics-related input variable standard names: character(len=25), public, protected :: phys_var_stdnames(phys_var_num) = (/ & @@ -64,9 +64,9 @@ module phys_vars_init_check_ddt_array "suite_name ", & "suite_part " /) !Array storing all registered IC file input names for each variable: - character(len=39), public, protected :: input_var_names(1, phys_var_num) = reshape((/ & - 'T(:, :, index_of_potential_temperature)', & - 'slp ' /), (/1, phys_var_num/)) + character(len=12), public, protected :: input_var_names(2, phys_var_num) = reshape((/ & + 'theta ', 'pot_temp ', & + 'slp ', 'sea_lev_pres' /), (/2, phys_var_num/)) ! Array indicating whether or not variable is protected: logical, public, protected :: protected_vars(phys_var_num)= (/ & diff --git a/test/unit/test_write_init_files.py b/test/unit/test_write_init_files.py index 86351216..d0736ee0 100644 --- a/test/unit/test_write_init_files.py +++ b/test/unit/test_write_init_files.py @@ -959,7 +959,7 @@ def test_ddt_array_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, _, ic_names = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -978,7 +978,7 @@ def test_ddt_array_reg_write_init(self): cap_database = capgen(run_env, return_db=True) # Generate physics initialization files: - retmsg = write_init.write_init_files(cap_database, {}, _TMP_DIR, + retmsg = write_init.write_init_files(cap_database, ic_names, _TMP_DIR, find_file, _INC_SEARCH_DIRS, 3, logger, phys_check_filename=vic_name, From 0635898db2139ac0eda9376cee46da81d33e645c Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Thu, 6 Jun 2024 19:18:23 -0600 Subject: [PATCH 21/79] more thoroughly separate physics history write from generate_registry --- cime_config/buildlib | 3 +- cime_config/cam_autogen.py | 67 +++- cime_config/cam_build_cache.py | 52 ++- cime_config/cam_config.py | 16 +- src/control/cam_comp.F90 | 8 +- src/data/generate_registry_data.py | 254 +++---------- src/data/registry.xml | 9 + src/data/write_hist_file.py | 590 +++++++++++++++++++++++++++++ 8 files changed, 793 insertions(+), 206 deletions(-) create mode 100644 src/data/write_hist_file.py diff --git a/cime_config/buildlib b/cime_config/buildlib index 214e6182..383c3893 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -78,6 +78,7 @@ def _build_cam(): dycore = config.get_value('dyn') reg_dir = config.get_value('reg_dir') init_dir = config.get_value('init_dir') + hist_dir = config.get_value('hist_dir') phys_dirs_str = config.get_value('phys_dirs') #Convert the phys_dirs_str into a proper list: @@ -90,7 +91,7 @@ def _build_cam(): filepath_src = os.path.join(caseroot, "Buildconf", "camconf", "Filepath") filepath_dst = os.path.join(bldroot, "Filepath") - paths = [source_mods_dir, reg_dir, init_dir, + paths = [source_mods_dir, reg_dir, init_dir, hist_dir, os.path.join(atm_root, "src", "data"), os.path.join(atm_root, "src", "control"), os.path.join(atm_root, "src", "cpl", diff --git a/cime_config/cam_autogen.py b/cime_config/cam_autogen.py index f6c9a69d..03ca500e 100644 --- a/cime_config/cam_autogen.py +++ b/cime_config/cam_autogen.py @@ -33,6 +33,7 @@ # Import needed registry and other src/data scripts: from generate_registry_data import gen_registry from write_init_files import write_init_files +from write_hist_file import write_hist_file ############################################################################### @@ -392,7 +393,7 @@ def generate_registry(data_search, build_cache, atm_root, bldroot, gen_fort_indent, source_mods_dir, atm_root, logger=_LOGGER, schema_paths=data_search, error_on_no_validate=True) - retcode, reg_file_list, ic_names = retvals + retcode, reg_file_list, ic_names, diag_names = retvals # Raise error if gen_registry failed: if retcode != 0: emsg = "ERROR:Unable to generate CAM data structures from {}, err = {}" @@ -406,14 +407,15 @@ def generate_registry(data_search, build_cache, atm_root, bldroot, # Save build details in the build cache reg_file_paths = [x.file_path for x in reg_file_list if x.file_path] build_cache.update_registry(gen_reg_file, registry_files, dycore, - reg_file_paths, ic_names) + reg_file_paths, ic_names, diag_names) else: # If we did not run the registry generator, retrieve info from cache reg_file_paths = build_cache.reg_file_list() ic_names = build_cache.ic_names() + diag_names = build_cache.diag_names() # End if - return genreg_dir, do_gen_registry, reg_file_paths, ic_names + return genreg_dir, do_gen_registry, reg_file_paths, ic_names, diag_names ############################################################################### def generate_physics_suites(build_cache, preproc_defs, host_name, @@ -679,6 +681,65 @@ def generate_init_routines(build_cache, bldroot, force_ccpp, force_init, return init_dir +############################################################################### +def generate_history_routines(build_cache, bldroot, force_ccpp, force_hist, + source_mods_dir, gen_fort_indent, + cap_database, diag_names): +############################################################################### + """ + Generate the host model history source code file + (physics_history.F90) using both the registry and the CCPP physics suites + if required (new case or changes to registry or CCPP source(s), meta-data, + and/or script). + """ + + #Add new directory to build path: + hist_dir = os.path.join(bldroot, "history") + # Use this for cache check + gen_hist_file = os.path.join(_REG_GEN_DIR, "write_hist_file.py") + + # Figure out if we need to generate new initialization routines: + if os.path.exists(hist_dir): + # Check if registry and / or CCPP suites were modified: + if force_ccpp or force_hist: + do_gen_hist = True + else: + #If not, then check cache to see if actual + #"write_init_files.py" was modified: + do_gen_hist = build_cache.hist_write_mismatch(gen_hist_file) + # end if + else: + #If no directory exists, then one will need + # to create new routines: + os.mkdir(hist_dir) + do_gen_hist = True + # End if + + if do_gen_hist: + + # Run initialization files generator: + # Yes, we are passing a pointer to the find_file function for use + # within write_init_files (so that write_init_files can be the place + # where the source include files are stored). + source_paths = [source_mods_dir, _REG_GEN_DIR] + retmsg = write_hist_file(cap_database, diag_names, hist_dir, + _find_file, source_paths, + gen_fort_indent, _LOGGER) + + #Check that script ran properly: + #----- + if retmsg: + emsg = "ERROR: Unable to generate CAM hist source code, error message is:\n{}" + raise CamAutoGenError(emsg.format(retmsg)) + #----- + + # save build details in the build cache + build_cache.update_hist_gen(gen_hist_file) + # End if + + return hist_dir + + ############# # End of file ############# diff --git a/cime_config/cam_build_cache.py b/cime_config/cam_build_cache.py index 2bda072e..83f304e2 100644 --- a/cime_config/cam_build_cache.py +++ b/cime_config/cam_build_cache.py @@ -213,6 +213,7 @@ def __init__(self, build_cache): # Set empty values sure to trigger processing self.__gen_reg_file = None self.__gen_init_file = None + self.__gen_hist_file = None self.__registry_files = {} self.__dycore = None self.__sdfs = {} @@ -226,6 +227,7 @@ def __init__(self, build_cache): self.__kind_types = {} self.__reg_gen_files = [] self.__ic_names = {} + self.__diag_names = {} if os.path.exists(build_cache): # Initialize build cache state _, cache = read_xml_file(build_cache) @@ -238,6 +240,9 @@ def __init__(self, build_cache): elif item.tag == 'generate_init_file': new_entry = new_entry_from_xml(item) self.__gen_init_file = new_entry + elif item.tag == 'generate_hist_file': + new_entry = new_entry_from_xml(item) + self.__gen_hist_file = new_entry elif item.tag == 'registry_file': new_entry = new_entry_from_xml(item) self.__registry_files[new_entry.key] = new_entry @@ -252,6 +257,9 @@ def __init__(self, build_cache): # end if itext = clean_xml_text(item) self.__ic_names[stdname].append(itext) + elif item.tag == 'diagnostic_name': + stdname = item.get('standard_name') + self.__diag_names[stdname] = clean_xml_text(item) else: emsg = "ERROR: Unknown registry tag, '{}'" raise ValueError(emsg.format(item.tag)) @@ -313,7 +321,7 @@ def __init__(self, build_cache): # end if def update_registry(self, gen_reg_file, registry_source_files, - dycore, reg_file_list, ic_names): + dycore, reg_file_list, ic_names, diag_names): """Replace the registry cache data with input data """ self.__dycore = dycore @@ -326,8 +334,10 @@ def update_registry(self, gen_reg_file, registry_source_files, # reg_file_list contains the files generated from the registry self.__reg_gen_files = reg_file_list # ic_names are the initial condition variable names from the registry, - # and should already be of type dict: + # diag_names are the diagnostic variable names from the registry, + # both should already be of type dict: self.__ic_names = ic_names + self.__diag_names = diag_names def update_ccpp(self, suite_definition_files, scheme_files, host_files, xml_files, namelist_meta_files, namelist_groups, @@ -367,11 +377,19 @@ def update_ccpp(self, suite_definition_files, scheme_files, host_files, def update_init_gen(self, gen_init_file): """ Replace the init_files writer - (generate_registry_data.py) cache + (write_init_files.py) cache data with input data """ self.__gen_init_file = FileStatus(gen_init_file, 'generate_init_file') + def update_hist_gen(self, gen_hist_file): + """ + Replace the hist_files writer + (write_hist_file.py) cache + data with input data + """ + self.__gen_hist_file = FileStatus(gen_hist_file, 'generate_hist_file') + def write(self): """Write out the current cache state""" new_cache = ET.Element("CAMBuildCache") @@ -380,6 +398,9 @@ def write(self): new_xml_entry(registry, 'generate_init_file', self.__gen_init_file.file_path, self.__gen_init_file.file_hash) + new_xml_entry(registry, 'generate_hist_file', + self.__gen_hist_file.file_path, + self.__gen_hist_file.file_hash) new_xml_entry(registry, 'generate_registry_file', self.__gen_reg_file.file_path, self.__gen_reg_file.file_hash) @@ -400,6 +421,11 @@ def write(self): ic_entry.text = ic_name # end for # end for + for stdname, diag_name in self.__diag_names.items(): + diag_entry = ET.SubElement(registry, 'diagnostic_name') + diag_entry.set('standard_name', stdname) + diag_entry.text = diag_name + # end for # CCPP ccpp = ET.SubElement(new_cache, 'CCPP') for sfile in self.__sdfs.values(): @@ -585,6 +611,22 @@ def init_write_mismatch(self, gen_init_file): #Return mismatch logical: return mismatch + def hist_write_mismatch(self, gen_hist_file): + """ + Determine if the hist_file writer (write_hist_file.py) + differs from the data stored in our cache. Return True + if the data differs. + """ + + #Initialize variable: + mismatch = False + + #Check file hash to see if mis-match exists: + mismatch = self.__gen_hist_file.hash_mismatch(gen_hist_file) + + #Return mismatch logical: + return mismatch + def scheme_nl_metadata(self): """Return the stored list of scheme namelist metadata files""" return self.__scheme_nl_metadata @@ -603,5 +645,9 @@ def ic_names(self): """Return a copy of the registry initial conditions dictionary""" return dict(self.__ic_names) + def diag_names(self): + """Return a copy of the registry diagnostic names dictionary""" + return dict(self.__diag_names) + ############# # End of file diff --git a/cime_config/cam_config.py b/cime_config/cam_config.py index 80bef16e..eb24e379 100644 --- a/cime_config/cam_config.py +++ b/cime_config/cam_config.py @@ -31,7 +31,7 @@ # Import fortran auto-generation routines: from cam_autogen import generate_registry, generate_physics_suites -from cam_autogen import generate_init_routines +from cam_autogen import generate_init_routines, generate_history_routines ############################################################################### #HELPER FUNCTIONS @@ -838,7 +838,7 @@ def generate_cam_src(self, gen_fort_indent): retvals = generate_registry(data_search, build_cache, self.__atm_root, self.__bldroot, source_mods_dir, dyn, gen_fort_indent) - reg_dir, force_ccpp, reg_files, ic_names = retvals + reg_dir, force_ccpp, reg_files, ic_names, diag_names = retvals #Add registry path to config object: reg_dir_desc = "Location of auto-generated registry code." @@ -877,6 +877,18 @@ def generate_cam_src(self, gen_fort_indent): init_dir_desc = "Location of auto-generated physics initialization code." self.create_config("init_dir", init_dir_desc, init_dir) + #--------------------------------------------------------- + # Create host model variable history routines + #--------------------------------------------------------- + hist_dir = generate_history_routines(build_cache, self.__bldroot, + force_ccpp, force_init, + source_mods_dir, gen_fort_indent, + capgen_db, diag_names) + + #Add registry path to config object: + hist_dir_desc = "Location of auto-generated physics history code." + self.create_config("hist_dir", hist_dir_desc, hist_dir) + #-------------------------------------------------------------- # write out the cache here as we have completed pre-processing #-------------------------------------------------------------- diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index 257da263..b4f3d4e8 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -26,8 +26,8 @@ module cam_comp use camsrfexch, only: cam_out_t, cam_in_t use physics_types, only: phys_state, phys_tend, dtime_phys - use physics_types_history, only: physics_types_history_init - use physics_types_history, only: physics_types_history_out + use physics_history, only: physics_history_init + use physics_history, only: physics_history_out use dyn_comp, only: dyn_import_t, dyn_export_t use perf_mod, only: t_barrierf, t_startf, t_stopf @@ -233,7 +233,7 @@ subroutine cam_init(caseid, ctitle, model_doi_url, & ! if (single_column) then ! call scm_intht() ! end if - call physics_types_history_init() + call physics_history_init() call history_init_files(model_doi_url, caseid, ctitle) end subroutine cam_init @@ -417,7 +417,7 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & !!XXgoldyXX: v need to import this ! call t_barrierf('sync_wshist', mpicom) ! call t_startf('wshist') - call physics_types_history_out() + call physics_history_out() call history_write_files() ! call t_stopf('wshist') !!XXgoldyXX: ^ need to import this diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 4674a118..30c7165d 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -139,14 +139,13 @@ class VarBase: __pointer_def_init = "NULL()" __pointer_type_str = "pointer" - def __init__(self, elem_node, local_name, dimensions, diag_name, known_types, + def __init__(self, elem_node, local_name, dimensions, known_types, type_default, units_default="", kind_default='', protected=False, index_name='', local_index_name='', local_index_name_str='', alloc_default='none', tstep_init_default=False): self.__local_name = local_name self.__dimensions = dimensions - self.__diagnostic_name = diag_name self.__units = elem_node.get('units', default=units_default) ttype = elem_node.get('type', default=type_default) self.__type = known_types.known_type(ttype) @@ -156,6 +155,7 @@ def __init__(self, elem_node, local_name, dimensions, diag_name, known_types, self.__initial_value = '' self.__initial_val_vars = set() self.__ic_names = None + self.__diagnostic_name = None self.__elements = [] self.__protected = protected self.__index_name = index_name @@ -187,7 +187,8 @@ def __init__(self, elem_node, local_name, dimensions, diag_name, known_types, elif attrib.tag == 'ic_file_input_names': #Separate out string into list: self.__ic_names = [x.strip() for x in attrib.text.split(' ') if x] - + elif attrib.tag == 'diagnostic': + self.__diagnostic_name = attrib.attrib['name'] # end if (just ignore other tags) # end for if ((not self.initial_value) and @@ -324,16 +325,16 @@ def dimensions(self): """Return the dimensions for this variable""" return self.__dimensions - @property - def diagnostic_name(self): - """Return the diagnostic name for this variable""" - return self.__diagnostic_name - @property def dimension_string(self): """Return the dimension_string for this variable""" return '(' + ', '.join(self.dimensions) + ')' + @property + def diagnostic_name(self): + """Return the diagnostic name for this variable""" + return self.__diagnostic_name + @property def long_name(self): """Return the long_name for this variable""" @@ -418,8 +419,8 @@ class ArrayElement(VarBase): """Documented array element of a registry Variable""" def __init__(self, elem_node, parent_name, dimensions, known_types, - diag_name, parent_type, parent_kind, parent_units, - parent_alloc, parent_tstep_init, vdict): + parent_type, parent_kind, parent_units, parent_alloc, + parent_tstep_init, vdict): """Initialize the Arary Element information by identifying its metadata properties """ @@ -467,7 +468,7 @@ def __init__(self, elem_node, parent_name, dimensions, known_types, ', '.join(dimensions))) # end if local_name = f'{parent_name}({self.index_string})' - super().__init__(elem_node, local_name, my_dimensions, diag_name, + super().__init__(elem_node, local_name, my_dimensions, known_types, parent_type, units_default=parent_units, kind_default=parent_kind, @@ -521,7 +522,6 @@ def __init__(self, var_node, known_types, vdict, logger): """Initialize a Variable from registry XML""" local_name = var_node.get('local_name') allocatable = var_node.get('allocatable', default="none") - diagnostic_name = None # Check attributes for att in var_node.attrib: if att not in Variable.__VAR_ATTRIBUTES: @@ -587,7 +587,7 @@ def __init__(self, var_node, known_types, vdict, logger): elif attrib.tag == 'ic_file_input_names': pass # picked up in parent elif attrib.tag == 'diagnostic': - diagnostic_name = attrib.attrib['name'] + pass # picked up in parent else: emsg = "Unknown Variable content, '{}'" raise CCPPError(emsg.format(attrib.tag)) @@ -595,7 +595,7 @@ def __init__(self, var_node, known_types, vdict, logger): # end for # Initialize the base class super().__init__(var_node, local_name, - my_dimensions, diagnostic_name, known_types, ttype, + my_dimensions, known_types, ttype, protected=protected) for attrib in var_node: @@ -603,7 +603,6 @@ def __init__(self, var_node, known_types, vdict, logger): if attrib.tag == 'element': self.elements.append(ArrayElement(attrib, local_name, my_dimensions, known_types, - diagnostic_name, ttype, self.kind, self.units, allocatable, self.tstep_init, vdict)) @@ -848,82 +847,6 @@ def write_tstep_init_routine(self, outfile, indent, # end if - def write_hist_init_routine(self, outfile, indent, ddt_str): - """ - Write calls to history_add_field for registry variables - """ - my_ddt = self.is_ddt - if my_ddt: - for var in my_ddt.variable_list(): - subi = indent - sub_ddt_str = f'{ddt_str}{self.local_name}%' - if var.diagnostic_name: - var.write_hist_init_routine(outfile, subi, sub_ddt_str) - # end if - # end if - else: - if self.diagnostic_name: - if 'vertical_layer_dimension' in self.dimensions: - vertical_dim_str = "'lev'" - elif 'vertical_interface_dimension' in self.dimensions: - vertical_dim_str = "'ilev'" - else: - vertical_dim_str = "horiz_only" - # endif - if self.is_constituent: - outfile.write('', 0) - outfile.write(f"call const_get_index('{self.standard_name}', const_index, abort=.false., warning=.false.)", indent) - outfile.write("if (const_index >= 0) then", indent) - outfile.write("const_props_ptr => cam_model_const_properties()", indent+1) - outfile.write("call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg)", indent + 1) - outfile.write("if (const_is_dry) then", indent + 1) - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"{vertical_dim_str}, 'avg', '{self.units}', mixing_ratio='dry')" - outfile.write(outstr, indent + 2) - outfile.write("else", indent + 1) - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"{vertical_dim_str}, 'avg', '{self.units}', mixing_ratio='wet')" - outfile.write(outstr, indent + 2) - outfile.write("end if", indent + 1) - outfile.write("end if", indent) - else: - outstr = f"call history_add_field('{self.diagnostic_name}', '{self.standard_name}', " \ - f"{vertical_dim_str}, 'avg', '{self.units}')" - outfile.write(outstr, indent) - # end if - # end if - # end if - - def write_hist_out_routine(self, outfile, indent, ddt_str): - """ - Write calls to history_out_field for registry variables - """ - my_ddt = self.is_ddt - if my_ddt: - for var in my_ddt.variable_list(): - subi = indent - sub_ddt_str = f'{ddt_str}{self.local_name}%' - if var.diagnostic_name: - var.write_hist_out_routine(outfile, subi, sub_ddt_str) - # end if - # end if - else: - if self.diagnostic_name: - if self.is_constituent: - outfile.write('', 0) - outfile.write(f"call const_get_index('{self.standard_name}', const_index, abort=.false., warning=.false.)", indent) - outfile.write("if (const_index >= 0) then", indent) - outfile.write("const_data_ptr => cam_constituents_array()", indent+1) - outstr = f"call history_out_field('{self.diagnostic_name}', const_data_ptr(:,:,const_index), size(const_data_ptr, 1))" - outfile.write(outstr, indent+1) - outfile.write("end if", indent) - else: - outstr = f"call history_out_field('{self.diagnostic_name}', {ddt_str}{self.local_name}, size({ddt_str}{self.local_name}, 1))" - outfile.write(outstr, indent) - # end if - # end if - # end if - @classmethod def constant_dimension(cls, dim): """Return dimension value if is a constant dimension, else None""" @@ -1443,30 +1366,6 @@ def write_source(self, outdir, indent, logger, physconst_vars): # end with - def write_history_source(self, outdir, indent, logger, physconst_vars): - """Write out source code for the variables in this file""" - module_name = f"{self.name}_history" - ofilename = os.path.join(outdir, f"{module_name}.F90") - logger.info(f"Writing registry history source file, {module_name}.F90") - file_desc = f"Interfaces for registry source file, {module_name}" - with FortranWriter(ofilename, "w", file_desc, - module_name, indent=indent) as outfile: - outfile.write("", 0) - self.write_hist_use_statements(outfile) - outfile.write_preamble() - # Write data management subroutine declarations - outfile.write('', 0) - outfile.write('!! public interfaces', 0) - outfile.write(f'public :: {self.hist_init_routine_name()}', 1) - outfile.write(f'public :: {self.hist_out_routine_name()}', 1) - # end of module header - outfile.end_module_header() - outfile.write("", 0) - # Write data management subroutines - self.write_hist_init_routine(outfile) - self.write_hist_out_routine(outfile) - # end with - def allocate_routine_name(self): """Return the name of the allocate routine for this module""" return f'allocate_{self.name}_fields' @@ -1475,14 +1374,6 @@ def tstep_init_routine_name(self): """Return the name of the physics timestep init routine for this module""" return f"{self.name}_tstep_init" - def hist_init_routine_name(self): - """Return the name of the history init routine for this module""" - return f"{self.name}_history_init" - - def hist_out_routine_name(self): - """Return the name of the history out routine for this module""" - return f"{self.name}_history_out" - def write_allocate_routine(self, outfile, physconst_vars): """Write a subroutine to allocate all the data in this module""" subname = self.allocate_routine_name() @@ -1551,73 +1442,6 @@ def write_tstep_init_routine(self, outfile, physconst_vars): outfile.write('', 0) outfile.write(f'end subroutine {subname}', 1) - def write_hist_use_statements(self, outfile): - """ - Write the use statements for all variables and DDTs in self.name - """ - outfile.write('', 0) - for var in self.__var_dict.variable_list(): - if not var.is_constituent: - outfile.write(f"use {self.name}, only: {var.local_name}", 1) - # end fi - # end if - outfile.write('', 0) - - def write_hist_init_routine(self, outfile): - """ - Write a subroutine to add all registry variables - to the master field list. - """ - subname = self.hist_init_routine_name() - outfile.write('', 0) - outfile.write(f'subroutine {subname}()', 1) - outfile.write('use cam_history, only: history_add_field', 2) - outfile.write('use cam_history_support, only: horiz_only', 2) - outfile.write('use cam_ccpp_cap, only: cam_model_const_properties', 2) - outfile.write('use cam_constituents, only: const_get_index', 2) - outfile.write('use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t', 2) - outfile.write('', 0) - outfile.write('!! Local variables', 2) - outfile.write('integer :: const_index', 2) - outfile.write('integer :: errcode', 2) - outfile.write('logical :: const_is_dry', 2) - outfile.write('character(len=256) :: errmsg', 2) - outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:)', 2) - subn_str = f'character(len=*), parameter :: subname = "{subname}"' - outfile.write(subn_str, 2) - for var in self.__var_dict.variable_list(): - var.write_hist_init_routine(outfile, 2, '') - # end for - outfile.write('', 0) - outfile.write(f'end subroutine {subname}', 1) - - def write_hist_out_routine(self, outfile): - """ - Write a subroutine to add all registry variables - to the master field list. - """ - subname = self.hist_out_routine_name() - outfile.write('', 0) - outfile.write(f'subroutine {subname}()', 1) - outfile.write('use cam_history, only: history_out_field', 2) - outfile.write('use cam_ccpp_cap, only: cam_constituents_array', 2) - outfile.write('use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t', 2) - outfile.write('use cam_constituents, only: const_get_index', 2) - outfile.write('use ccpp_kinds, only: kind_phys', 2) - outfile.write('', 0) - outfile.write('!! Local variables', 2) - outfile.write('real(kind_phys), pointer :: const_data_ptr(:,:,:)', 2) - outfile.write('character(len=512) :: standard_name', 2) - outfile.write('integer :: const_index', 2) - subn_str = f'character(len=*), parameter :: subname = "{subname}"' - outfile.write(subn_str, 2) - outfile.write('',0) - for var in self.__var_dict.variable_list(): - var.write_hist_out_routine(outfile, 2, '') - # end for - outfile.write('', 0) - outfile.write(f'end subroutine {subname}', 1) - @property def name(self): """Return this File's name""" @@ -1859,7 +1683,7 @@ def write_registry_files(registry, dycore, outdir, src_mod, src_root, if file_.generate_code: file_.write_metadata(outdir, logger) file_.write_source(outdir, indent, logger, physconst_vars) - file_.write_history_source(outdir, indent, logger, physconst_vars) +# file_.write_history_source(outdir, indent, logger, physconst_vars) # end if # end for @@ -1919,6 +1743,48 @@ def _create_ic_name_dict(registry): # end for return ic_name_dict +############################################################################### +def _create_diag_name_dict(registry): +############################################################################### + """ Build a dictionary of diagnostic names (key = standard_name) + If this property is ever included in CCPP metadata, this + section can be replaced by accessing the new metadata + property and this routine will no longer be needed. + This function returns a dictionary containing only the variables + from the registry which have the "diagnostic" element. + """ + diag_name_dict = {} + for section in registry: + if section.tag == 'file': + for obj in section: + if obj.tag == 'variable': + for attrib in obj: + if attrib.tag == 'diagnostic': + stdname = obj.get('standard_name') + diag_name = attrib.attrib['name'] + # peverwhee - duplicate check? + diag_name_dict[stdname] = diag_name + # end if + # end for + elif obj.tag == 'array': + for subobj in obj: + if subobj.tag == 'element': + for attrib in obj: + if attrib.tag == 'diagnostic': + stdname = obj.get('standard_name') + diag_name = attrib.attrib['name'] + # peverwhee - duplicate check? + diag_name_dict[stdname] = diag_name + # end if + # end for + # end if + # end for + # end if (ignore other node types) + # end for + # end if (ignore other node types) + # end for + return diag_name_dict + ############################################################################### def gen_registry(registry_file, dycore, outdir, indent, src_mod, src_root, loglevel=None, logger=None, @@ -1988,6 +1854,7 @@ def gen_registry(registry_file, dycore, outdir, indent, retcode = 1 files = None ic_names = None + diag_names = None else: library_name = registry.get('name') emsg = f"Parsing registry, {library_name}" @@ -1997,9 +1864,10 @@ def gen_registry(registry_file, dycore, outdir, indent, src_root, reg_dir, indent, logger) # See comment in _create_ic_name_dict ic_names = _create_ic_name_dict(registry) + diag_names = _create_diag_name_dict(registry) retcode = 0 # Throw exception on error # end if - return retcode, files, ic_names + return retcode, files, ic_names, diag_names def main(): """Function to execute when module called as a script""" @@ -2024,5 +1892,5 @@ def main(): ############################################################################### if __name__ == "__main__": - __RETCODE, _FILES, _IC_NAMES = main() + __RETCODE, _FILES, _IC_NAMES, _DIAG_NAMES = main() sys.exit(__RETCODE) diff --git a/src/data/registry.xml b/src/data/registry.xml index c2401b44..d9a9648a 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -75,6 +75,7 @@ allocatable="pointer"> horizontal_dimension vertical_layer_dimension s state_s + Vertical pressure velocity horizontal_dimension vertical_layer_dimension omega state_omega + horizontal_dimension vertical_layer_dimension pmid state_pmid + horizontal_dimension vertical_layer_dimension pdeldry state_pdeldry + horizontal_dimension vertical_layer_dimension zm state_zm + horizontal_dimension vertical_interface_dimension zi state_zi + Change in temperature from a parameterization horizontal_dimension vertical_layer_dimension dTdt tend_dtdt + Change in eastward wind from a parameterization horizontal_dimension vertical_layer_dimension dudt tend_dudt + Change in northward wind from a parameterization horizontal_dimension vertical_layer_dimension dvdt tend_dvdt + in and add it to if found and + not of type, 'host'. + If not found, add to . + If found and added to , also process the standard names of + any intrinsic sub-elements of . + Return the list of (if any). + Note: This function has a side effect (adding to ). + """ + missing_vars = [] + hvar = host_dict.find_variable(stdname) + if hvar and (hvar.source.ptype != 'host'): + var_dict[stdname] = hvar + # Process elements (if any) + ielem = hvar.intrinsic_elements() + # List elements are the only ones we care about + if isinstance(ielem, list): + for sname in ielem: + smissing = _find_and_add_host_variable(sname, host_dict, + var_dict) + missing_vars.extend(smissing) + # end for + # end if + # end if + if not hvar: + missing_vars.append(stdname) + # end if + return missing_vars + +############################################################################## +def gather_ccpp_req_vars(cap_database): + """ + Generate a list of host-model and constituent variables + required by the CCPP physics suites potentially being used + in this model run. + is the database object returned by capgen. + It is an error if any physics suite variable is not accessible in + the host model. + Return several values: + - A list of host model variables + - An error message (blank for no error) + """ + + # Dictionary of all 'in' and 'inout' suite variables. + # Key is standard name, value is host-model or constituent variable + req_vars = {} + missing_vars = set() + constituent_vars = set() + retmsg = "" + # Host model dictionary + host_dict = cap_database.host_model_dict() + + # Create CCPP datatable required variables-listing object: + # XXgoldyXX: Choose only some phases here? + for phase in CCPP_STATE_MACH.transitions(): + for cvar in cap_database.call_list(phase).variable_list(): + stdname = cvar.get_prop_value('standard_name') + intent = cvar.get_prop_value('intent') + is_const = cvar.get_prop_value('advected') + if ((intent in _INPUT_TYPES) and + (stdname not in req_vars) and + (stdname not in _EXCLUDED_STDNAMES)): + if is_const: + #Variable is a constituent, so may not be known + #until runtime, but still need variable names in order + #to read from a file if need be: + req_vars[stdname] = cvar + + #Add variable to constituent set: + constituent_vars.add(stdname) + else: + # We need to work with the host model version of this variable + missing = _find_and_add_host_variable(stdname, host_dict, + req_vars) + missing_vars.update(missing) + # end if + # end if (do not include output variables) + # end for (loop over call list) + # end for (loop over phases) + + if missing_vars: + mvlist = ', '.join(sorted(missing_vars)) + retmsg = f"Error: Missing required host variables: {mvlist}" + # end if + # Return the required variables as a list + return list(req_vars.values()), constituent_vars, retmsg + +########################## +#FORTRAN WRITING FUNCTIONS +########################## + +def _get_host_model_import(hvar, import_dict, host_dict): + """Add import information (module, local_name) for to + . is used to look up any sub-variables + (e.g., array indices). + Note: This function has side effects but no return value + """ + missing_indices = [] + # Extract module name: + use_mod_name = hvar.source.name + # Check if module name is already in dictionary: + if use_mod_name not in import_dict: + # Create an empty entry for this module + import_dict[use_mod_name] = set() + # end if + # Add the variable + var_locname = hvar.var.get_prop_value('local_name') + import_dict[use_mod_name].add(var_locname) + aref = hvar.array_ref() + if aref: + dimlist = [x.strip() for x in aref.group(2).split(',')] + for dim in dimlist: + if dim != ':': + dvar = host_dict.find_variable(dim) + if dvar: + _get_host_model_import(dvar, import_dict, host_dict) + else: + missing_indices.append(dim) + # end if + # end if + # end for + # end if + if missing_indices: + mi_str = ", ".join(missing_indices) + raise CamInitWriteError(f"Missing host indices: {mi_str}.") + # end if + +def collect_host_var_imports(host_vars, host_dict, constituent_set, diag_dict): + """Construct a dictionary of host-model variables to import keyed by + host-model module name. + is used to look up array-reference indices. + Return a list of module / import vars combinations of the following form: + [[, [. + """ + + # The plus one is for a comma + max_modname = max(len(x[0]) for x in use_stmts) + 1 + # max_modspace is the max chars of the module plus other 'use' statement + # syntax (e.g., 'only:') + max_modspace = (outfile.indent_size * indent) + max_modname + 10 + mod_space = outfile.line_fill - max_modspace + for use_item in use_stmts: + # Break up imported interfaces to clean up use statements + larg = 0 + num_imports = len(use_item[1]) + while larg < num_imports: + int_str = use_item[1][larg] + larg = larg + 1 + while ((larg < num_imports) and + ((len(int_str) + len(use_item[1][larg]) + 2) < mod_space)): + int_str += f", {use_item[1][larg]}" + larg = larg + 1 + # end while + modname = use_item[0] + ',' + outfile.write(f"use {modname: <{max_modname}} only: {int_str}", + indent) + # end while + # end for + +###### + +def get_dimension_info(hvar): + """Retrieve dimension information from . + Return the following values: + - The local variable name of the vertical dimension (or None) + - True if has one dimension which is a horizontal dimension or + if has two dimensions (horizontal and vertical) + """ + vdim_name = None + legal_dims = False + fail_reason = "" + dims = hvar.get_dimensions() + levnm = hvar.has_vertical_dimension() + # is only 'legal' for 2 or 3 dimensional fields (i.e., 1 or 2 + # dimensional variables). The second dimension must be vertical. + # XXgoldyXX: If we ever need to read scalars, it would have to be + # done using global attributes, not 'infld'. + ldims = len(dims) + lname = hvar.get_prop_value('local_name') + suff = "" + legal_dims = True + if not hvar.has_horizontal_dimension(): + legal_dims = False + fail_reason += f"{suff}{lname} has no horizontal dimension" + suff = "; " + # end if + if (ldims > 2) or ((ldims > 1) and (not levnm)): + legal_dims = False + unsupp = [] + for dim in dims: + if ((not is_horizontal_dimension(dim)) and + (not is_vertical_dimension(dim))): + if dim[0:18] == "ccpp_constant_one:": + rdim = dim[18:] + else: + rdim = dim + # end if + unsupp.append(rdim) + # end if + # end for + if len(unsupp) > 1: + udims = ', '.join(unsupp[:-1]) + if len(unsupp) > 2: + udims += ',' + # end if + udims += f" and {unsupp[-1]}" + fail_reason += f"{suff}{lname} has unsupported dimensions, {udims}." + else: + udims = unsupp[0] if unsupp else "unknown" + fail_reason += f"{suff}{lname} has unsupported dimension, {udims}." + # end if + suff = "; " + # end if + if legal_dims and levnm: + # should be legal, find the correct local name for the + # vertical dimension + dparts = levnm.split(':') + if (len(dparts) == 2) and (dparts[0].lower() == 'ccpp_constant_one'): + levnm = dparts[1] + elif len(dparts) == 1: + levnm = dparts[0] + else: + # This should not happen so crash + raise ValueError(f"Unsupported vertical dimension, '{levnm}'") + # end if + if levnm == 'vertical_layer_dimension': + vdim_name = "lev" + elif levnm == 'vertical_interface_dimension': + vdim_name = "ilev" + # end if (no else, will be processed as an error below) + + if vdim_name is None: + # This should not happen so crash + raise ValueError(f"Vertical dimension, '{levnm}', not found") + # end if + # end if + return vdim_name, legal_dims, fail_reason + +def write_physics_history_init_subroutine(outfile, host_dict, host_vars, host_imports, + diag_dict, phys_check_fname_str, constituent_set): + + """ + Write the "physics_history_init" subroutine, which + is used to call history_add_field for all + physics variables. + """ + + # ----------------------------------------- + # Write subroutine code: + # ----------------------------------------- + + # Add subroutine header + outfile.write(f"subroutine physics_history_init()", 1) + + # Add use statements: + use_stmts = [["cam_ccpp_cap", ["cam_model_const_properties"]], + ["cam_history", ["history_add_field"]], + ["cam_history_support", ["horiz_only"]], + ["cam_constituents", ["const_get_index"]], + ["ccpp_constituent_prop_mod", ["ccpp_constituent_prop_ptr_t"]]] + + # Add in host model data use statements + use_stmts.extend(host_imports) + write_use_statements(outfile, use_stmts, 2) + outfile.blank_line() + + # Write local variable declarations: + outfile.comment("Local variables:", 2) + outfile.blank_line() + + outfile.write('integer :: const_index', 2) + outfile.write('integer :: errcode', 2) + outfile.write('logical :: const_is_dry', 2) + outfile.write('character(len=256) :: errmsg', 2) + outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:)', 2) + subn_str = 'character(len=*), parameter :: subname = "physics_history_init"' + outfile.write(subn_str, 2) + outfile.blank_line() + + # ----------------------------------------- + # Create Fortran "history_add_field" calls: + # ----------------------------------------- + + # Loop over all variable standard names: + for hvar in host_vars: + var_stdname = hvar.get_prop_value('standard_name') + var_locname = hvar.call_string(host_dict) + var_units = hvar.get_prop_value('units') + vdim_name, legal_dims, fail_reason = get_dimension_info(hvar) + if vdim_name is not None: + vdim = f"'{vdim_name}'" + else: + vdim = 'horiz_only' + # end if + + # only add add_field call if the variable has a diagnostic name + if var_stdname not in diag_dict: + continue + # end if + + diag_name = diag_dict[var_stdname] + + # Ignore any variable that is listed as a constiutuent, + # as they will be handled separately by the constituents object: + if var_stdname in constituent_set: + outfile.write(f"call const_get_index('{var_stdname}', const_index, abort=.false., warning=.false.)", 2) + outfile.write("if (const_index >= 0) then", 2) + outfile.write("const_props_ptr => cam_model_const_properties()", 3) + outfile.write("call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg)", 3) + outfile.write("if (const_is_dry) then", 3) + outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ + f"{vdim}, 'avg', '{var_units}', mixing_ratio='dry')" + outfile.write(outstr, 4) + outfile.write("else", 3) + outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ + f"{vdim}, 'avg', '{var_units}', mixing_ratio='wet')" + outfile.write(outstr, 4) + outfile.write("end if", 3) + outfile.write("end if", 2) + else: + outstr = f"call history_add_field('{diag_name}', '{var_stdname}', {vdim}, 'avg', '{var_units}')" + outfile.write(outstr, 2) + # end if + # end for + # End subroutine: + outfile.blank_line() + outfile.write("end subroutine physics_history_init", 1) + +##### + +def write_physics_history_out_subroutine(outfile, host_dict, host_vars, host_imports, + diag_dict, phys_check_fname_str, constituent_set): + + """ + Write the "physics_history_out" subroutine, which + is used to call history_out_field for all + physics variables in the registry. + """ + + # ----------------------------------------- + # Write subroutine code: + # ----------------------------------------- + + # Add subroutine header + outfile.write(f"subroutine physics_history_out()", 1) + + # Add use statements: + use_stmts = [["cam_ccpp_cap", ["cam_constituents_array"]], + ["cam_history", ["history_out_field"]], + ["cam_constituents", ["const_get_index"]], + ["ccpp_kinds", ["kind_phys"]], + ["ccpp_constituent_prop_mod", ["ccpp_constituent_prop_ptr_t"]]] + + # Add in host model data use statements + use_stmts.extend(host_imports) + write_use_statements(outfile, use_stmts, 2) + outfile.blank_line() + + # Write local variable declarations: + outfile.comment("Local variables:", 2) + outfile.blank_line() + + outfile.write('!! Local variables', 2) + outfile.write('real(kind_phys), pointer :: const_data_ptr(:,:,:)', 2) + outfile.write('character(len=512) :: standard_name', 2) + outfile.write('integer :: const_index', 2) + subn_str = 'character(len=*), parameter :: subname = "physics_history_out"' + outfile.write(subn_str, 2) + outfile.blank_line() + + # ----------------------------------------- + # Create Fortran "history_add_field" calls: + # ----------------------------------------- + + # Loop over all variable standard names: + for hvar in host_vars: + var_stdname = hvar.get_prop_value('standard_name') + var_locname = hvar.call_string(host_dict) + + # only add add_field call if the variable has a diagnostic name + if var_stdname not in diag_dict: + continue + # end if + + diag_name = diag_dict[var_stdname] + + # Ignore any variable that is listed as a constiutuent, + # as they will be handled separately by the constituents object: + if var_stdname in constituent_set: + outfile.write(f"call const_get_index('{var_stdname}', const_index, abort=.false., warning=.false.)", 2) + outfile.write("if (const_index >= 0) then", 2) + outfile.write("const_data_ptr => cam_constituents_array()", 3) + outstr = f"call history_out_field('{diag_name}', const_data_ptr(:,:,const_index), size(const_data_ptr, 1))" + outfile.write(outstr, 3) + outfile.write("end if", 2) + else: + outstr = f"call history_out_field('{diag_name}', {var_locname}, size({var_locname}, 1))" + outfile.write(outstr, 2) + # end if + # end for + # End subroutine: + outfile.blank_line() + outfile.write("end subroutine physics_history_out", 1) + + # ---------------------------- + +############# +# End of file +############# From f76b038fca172cb4f1d1394dbb0c9752c50e3ad1 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 7 Jun 2024 16:49:59 -0600 Subject: [PATCH 22/79] Standard names update. --- src/data/physconst.meta | 2 +- src/dynamics/utils/hycoef.F90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/data/physconst.meta b/src/data/physconst.meta index c900f8f4..095dd0b8 100644 --- a/src/data/physconst.meta +++ b/src/data/physconst.meta @@ -268,7 +268,7 @@ dimensions = () protected = True [ epsilo ] - standard_name = ratio_of_h2o_to_dry_air_molecular_weights + standard_name = ratio_of_water_vapor_to_dry_air_molecular_weights units = 1 type = real | kind = kind_phys dimensions = () diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 6cb618fa..33817faa 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -423,7 +423,7 @@ subroutine hycoef_read(File) ierr = PIO_Inq_DimID(File, 'ilev', lev_dimid) if (ierr /= PIO_NOERR) then - ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer_at_interface', lev_dimid) + ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer_at_interfaces', lev_dimid) if (ierr /= PIO_NOERR) then call endrun(routine//': reading ilev') end if @@ -436,7 +436,7 @@ subroutine hycoef_read(File) ierr = pio_inq_varid(File, 'hyai', hyai_desc) if (ierr /= PIO_NOERR) then - ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient_at_interface', hyai_desc) + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient_at_interfaces', hyai_desc) if (ierr /= PIO_NOERR) then call endrun(routine//': reading hyai') end if @@ -452,7 +452,7 @@ subroutine hycoef_read(File) ierr = pio_inq_varid(File, 'hybi', hybi_desc) if (ierr /= PIO_NOERR) then - ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient_at_interface', hybi_desc) + ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient_at_interfaces', hybi_desc) if (ierr /= PIO_NOERR) then call endrun(routine//': reading hybi') end if From 0f53092992c024c78f4b106de6437fe2c164e6e9 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 7 Jun 2024 16:50:12 -0600 Subject: [PATCH 23/79] Update to latest atmos_phys --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 66c975af..90fbed6a 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -2,7 +2,7 @@ local_path = ccpp_framework protocol = git repo_url = https://github.com/peverwhee/ccpp-framework -tag = CPF_0.2.056 +tag = 7781d11383a2bd20d8958153ad8d857d8a09f8be required = True [mpas] @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = 70fdba87b999a4b1f495208a7eee7e0e2dd185ce +tag = a824aa75db0fcbec8d017ece4cb472ad633982d9 required = True [externals_description] From 7591a270fff7a3494b7aa130aff3231afe5ca2dc Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 7 Jun 2024 16:51:47 -0600 Subject: [PATCH 24/79] Update to match generated code from capgen. --- src/control/cam_comp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index a36f4cca..01557943 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -607,8 +607,8 @@ subroutine cam_register_constituents(cam_runtime_opts) !Combine host and physics constituents into a single !constituents object: - call cam_ccpp_register_constituents(cam_runtime_opts%suite_as_list(), & - host_constituents, dynamic_constituents, errcode=errflg, errmsg=errmsg) + call cam_ccpp_register_constituents( & + host_constituents, errcode=errflg, errmsg=errmsg) if (errflg /= 0) then call endrun(subname//trim(errmsg), file=__FILE__, line=__LINE__) From 52d9b069414c8b5f81eead843390fda1ed0f03ca Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 7 Jun 2024 18:56:03 -0600 Subject: [PATCH 25/79] create register history tests; update existing tests --- src/data/generate_registry_data.py | 4 +- src/data/write_hist_file.py | 12 +- src/history/cam_hist_file.F90 | 8 +- .../build_cache_files/example_build_cache.xml | 1 + .../update_ccpp_build_cache.xml | 1 + .../update_init_gen_build_cache.xml | 1 + .../update_reg_build_cache.xml | 2 + test/unit/sample_files/reg_good_ddt.xml | 2 + test/unit/sample_files/reg_good_ddt_array.xml | 3 + test/unit/sample_files/reg_good_simple.xml | 4 +- .../write_hist_file/physics_history_ddt.F90 | 74 +++ .../write_hist_file/physics_history_ddt2.F90 | 74 +++ .../physics_history_ddt_array.F90 | 74 +++ .../physics_history_no_req_var.F90 | 68 +++ .../physics_history_simple.F90 | 87 ++++ .../write_init_files/ddt2_reg.xml | 3 + .../write_init_files/ddt_array_reg.xml | 2 + .../sample_files/write_init_files/ddt_reg.xml | 2 + .../write_init_files/no_req_var_reg.xml | 3 + .../simple_build_cache_template.xml | 7 +- .../write_init_files/simple_reg.xml | 3 + test/unit/test_build_cache.py | 4 +- test/unit/test_cam_autogen.py | 8 +- test/unit/test_registry.py | 18 +- test/unit/test_write_hist_file.py | 486 ++++++++++++++++++ test/unit/test_write_init_files.py | 14 +- 26 files changed, 933 insertions(+), 32 deletions(-) create mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt.F90 create mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 create mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 create mode 100644 test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 create mode 100644 test/unit/sample_files/write_hist_file/physics_history_simple.F90 create mode 100644 test/unit/test_write_hist_file.py diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 30c7165d..fea6be1d 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -1769,9 +1769,9 @@ def _create_diag_name_dict(registry): elif obj.tag == 'array': for subobj in obj: if subobj.tag == 'element': - for attrib in obj: + for attrib in subobj: if attrib.tag == 'diagnostic': - stdname = obj.get('standard_name') + stdname = subobj.get('standard_name') diag_name = attrib.attrib['name'] # peverwhee - duplicate check? diag_name_dict[stdname] = diag_name diff --git a/src/data/write_hist_file.py b/src/data/write_hist_file.py index 37e7c1b9..8441b313 100644 --- a/src/data/write_hist_file.py +++ b/src/data/write_hist_file.py @@ -47,7 +47,7 @@ ############## def write_hist_file(cap_database, diag_names, outdir, file_find_func, - source_paths, indent, logger): + source_paths, indent, logger, phys_hist_filename=None): """ Create the physics history Fortran file using a database @@ -84,8 +84,13 @@ def write_hist_file(cap_database, diag_names, outdir, file_find_func, # ----------------------------------------- # Open new file: - ofilename = os.path.join(outdir, "physics_history.F90") - physics_history_fname_str = "physics_history" + if phys_hist_filename: + ofilename = os.path.join(outdir, phys_hist_filename) + # Get file name, ignoring file type: + physics_history_fname_str = os.path.splitext(phys_hist_filename)[0] + else: + ofilename = os.path.join(outdir, "physics_history.F90") + physics_history_fname_str = "physics_history" # end if # Log file creation: @@ -229,7 +234,6 @@ def gather_ccpp_req_vars(cap_database): # end if (do not include output variables) # end for (loop over call list) # end for (loop over phases) - if missing_vars: mvlist = ', '.join(sorted(missing_vars)) retmsg = f"Error: Missing required host variables: {mvlist}" diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 699a5e90..a335165f 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -601,7 +601,7 @@ subroutine config_set_up_fields(this, possible_field_list) use cam_history_support, only: max_chars use cam_logfile, only: iulog use spmd_utils, only: masterproc - use cam_abortutils, only: check_allocate + use cam_abortutils, only: check_allocate, endrun ! Dummy arguments class(hist_file_t), intent(inout) :: this @@ -622,6 +622,7 @@ subroutine config_set_up_fields(this, possible_field_list) integer, allocatable :: field_shape(:) integer, allocatable :: beg_dim(:) integer, allocatable :: end_dim(:) + character(len=128) :: errmsg type(hist_log_messages) :: errors @@ -630,6 +631,7 @@ subroutine config_set_up_fields(this, possible_field_list) file=__FILE__, line=__LINE__-1) possible_grids = -1 num_grids = 0 + errmsg = '' do idx = 1, size(this%field_names) ! Find the relevant field in the possible field list field_ptr_entry => possible_field_list%table_value(this%field_names(idx)) @@ -637,8 +639,8 @@ subroutine config_set_up_fields(this, possible_field_list) type is (hist_field_info_t) field_ptr => field_ptr_entry class default - ! some error message here - return + write(errmsg,'(3a)') 'ERROR Field : ',trim(this%field_names(idx)),' not available' + call endrun(subname//errmsg, file=__FILE__, line=__LINE__) end select ! peverwhee - TODO: check for duplicate field ? call field_ptr%dimensions(dimensions) diff --git a/test/unit/sample_files/build_cache_files/example_build_cache.xml b/test/unit/sample_files/build_cache_files/example_build_cache.xml index f10dfd27..4530d6c1 100644 --- a/test/unit/sample_files/build_cache_files/example_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/example_build_cache.xml @@ -3,6 +3,7 @@ + none /yellow/brick/road/munchkin.meta diff --git a/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml b/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml index 7b84bf52..ca7a10c3 100644 --- a/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml @@ -2,6 +2,7 @@ + none diff --git a/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml b/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml index 62a8909a..eb142a1c 100644 --- a/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml @@ -2,6 +2,7 @@ + none diff --git a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml index e773ee2c..5e5b19af 100644 --- a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml @@ -2,12 +2,14 @@ + banana tmp/cam_build_cache/test_reg.xml heart brain + TOTO diff --git a/test/unit/sample_files/reg_good_ddt.xml b/test/unit/sample_files/reg_good_ddt.xml index fe2fc701..8d633a07 100644 --- a/test/unit/sample_files/reg_good_ddt.xml +++ b/test/unit/sample_files/reg_good_ddt.xml @@ -15,6 +15,7 @@ allocatable="pointer" access="protected"> horizontal_dimension lat + Composition-dependent ratio of dry air gas constant to specific heat at constant pressure horizontal_dimension vertical_layer_dimension rair/cpair + horizontal_dimension diff --git a/test/unit/sample_files/reg_good_ddt_array.xml b/test/unit/sample_files/reg_good_ddt_array.xml index 5cc3adfc..40f2c891 100644 --- a/test/unit/sample_files/reg_good_ddt_array.xml +++ b/test/unit/sample_files/reg_good_ddt_array.xml @@ -17,6 +17,7 @@ units="count" type="integer" access="protected"> Number of horizontal columns 0 + horizontal_dimension lon + CLDLIQ CLDLIQ_snapshot + diff --git a/test/unit/sample_files/reg_good_simple.xml b/test/unit/sample_files/reg_good_simple.xml index 66451ae0..c5b07390 100644 --- a/test/unit/sample_files/reg_good_simple.xml +++ b/test/unit/sample_files/reg_good_simple.xml @@ -19,12 +19,14 @@ allocatable="pointer" access="protected"> horizontal_dimension lon + - + The coolest constituent imaginable COOL_CAT cnst_COOL_CAT + diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 new file mode 100644 index 00000000..8f796bdc --- /dev/null +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 @@ -0,0 +1,74 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated Physics history source file +!! +! +module physics_history_ddt + + + implicit none + private + + +!! public interfaces + public :: physics_history_init + public :: physics_history_out + +CONTAINS + + subroutine physics_history_init() + use cam_ccpp_cap, only: cam_model_const_properties + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + use cam_constituents, only: const_get_index + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt, only: phys_state, slp + + ! Local variables: + + integer :: const_index + integer :: errcode + logical :: const_is_dry + character(len=256) :: errmsg + type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) + character(len=*), parameter :: subname = "physics_history_init" + + call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') + call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') + + end subroutine physics_history_init + + subroutine physics_history_out() + use cam_ccpp_cap, only: cam_constituents_array + use cam_history, only: history_out_field + use cam_constituents, only: const_get_index + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt, only: phys_state, slp + + ! Local variables: + + !! Local variables + real(kind_phys), pointer :: const_data_ptr(:,:,:) + character(len=512) :: standard_name + integer :: const_index + character(len=*), parameter :: subname = "physics_history_out" + + call history_out_field('THETA', phys_state%theta, size(phys_state%theta, 1)) + call history_out_field('SLP', slp, size(slp, 1)) + + end subroutine physics_history_out + +end module physics_history_ddt diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 new file mode 100644 index 00000000..010de78a --- /dev/null +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 @@ -0,0 +1,74 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated Physics history source file +!! +! +module physics_history_ddt2 + + + implicit none + private + + +!! public interfaces + public :: physics_history_init + public :: physics_history_out + +CONTAINS + + subroutine physics_history_init() + use cam_ccpp_cap, only: cam_model_const_properties + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + use cam_constituents, only: const_get_index + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt2, only: phys_state + + ! Local variables: + + integer :: const_index + integer :: errcode + logical :: const_is_dry + character(len=256) :: errmsg + type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) + character(len=*), parameter :: subname = "physics_history_init" + + call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') + call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') + + end subroutine physics_history_init + + subroutine physics_history_out() + use cam_ccpp_cap, only: cam_constituents_array + use cam_history, only: history_out_field + use cam_constituents, only: const_get_index + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt2, only: phys_state + + ! Local variables: + + !! Local variables + real(kind_phys), pointer :: const_data_ptr(:,:,:) + character(len=512) :: standard_name + integer :: const_index + character(len=*), parameter :: subname = "physics_history_out" + + call history_out_field('THETA', phys_state%theta, size(phys_state%theta, 1)) + call history_out_field('SLP', phys_state%slp, size(phys_state%slp, 1)) + + end subroutine physics_history_out + +end module physics_history_ddt2 diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 new file mode 100644 index 00000000..7e630d88 --- /dev/null +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 @@ -0,0 +1,74 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated Physics history source file +!! +! +module physics_history_ddt_array + + + implicit none + private + + +!! public interfaces + public :: physics_history_init + public :: physics_history_out + +CONTAINS + + subroutine physics_history_init() + use cam_ccpp_cap, only: cam_model_const_properties + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + use cam_constituents, only: const_get_index + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt_array, only: ix_theta, phys_state + + ! Local variables: + + integer :: const_index + integer :: errcode + logical :: const_is_dry + character(len=256) :: errmsg + type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) + character(len=*), parameter :: subname = "physics_history_init" + + call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') + call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') + + end subroutine physics_history_init + + subroutine physics_history_out() + use cam_ccpp_cap, only: cam_constituents_array + use cam_history, only: history_out_field + use cam_constituents, only: const_get_index + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_ddt_array, only: ix_theta, phys_state + + ! Local variables: + + !! Local variables + real(kind_phys), pointer :: const_data_ptr(:,:,:) + character(len=512) :: standard_name + integer :: const_index + character(len=*), parameter :: subname = "physics_history_out" + + call history_out_field('THETA', phys_state%T(:, :, ix_theta), size(phys_state%T(:, :, ix_theta), 1)) + call history_out_field('SLP', phys_state%slp, size(phys_state%slp, 1)) + + end subroutine physics_history_out + +end module physics_history_ddt_array diff --git a/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 b/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 new file mode 100644 index 00000000..5409d491 --- /dev/null +++ b/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 @@ -0,0 +1,68 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated Physics history source file +!! +! +module physics_history_no_req_var + + + implicit none + private + + +!! public interfaces + public :: physics_history_init + public :: physics_history_out + +CONTAINS + + subroutine physics_history_init() + use cam_ccpp_cap, only: cam_model_const_properties + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + use cam_constituents, only: const_get_index + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + + ! Local variables: + + integer :: const_index + integer :: errcode + logical :: const_is_dry + character(len=256) :: errmsg + type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) + character(len=*), parameter :: subname = "physics_history_init" + + + end subroutine physics_history_init + + subroutine physics_history_out() + use cam_ccpp_cap, only: cam_constituents_array + use cam_history, only: history_out_field + use cam_constituents, only: const_get_index + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + + ! Local variables: + + !! Local variables + real(kind_phys), pointer :: const_data_ptr(:,:,:) + character(len=512) :: standard_name + integer :: const_index + character(len=*), parameter :: subname = "physics_history_out" + + + end subroutine physics_history_out + +end module physics_history_no_req_var diff --git a/test/unit/sample_files/write_hist_file/physics_history_simple.F90 b/test/unit/sample_files/write_hist_file/physics_history_simple.F90 new file mode 100644 index 00000000..d39f1674 --- /dev/null +++ b/test/unit/sample_files/write_hist_file/physics_history_simple.F90 @@ -0,0 +1,87 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated Physics history source file +!! +! +module physics_history_simple + + + implicit none + private + + +!! public interfaces + public :: physics_history_init + public :: physics_history_out + +CONTAINS + + subroutine physics_history_init() + use cam_ccpp_cap, only: cam_model_const_properties + use cam_history, only: history_add_field + use cam_history_support, only: horiz_only + use cam_constituents, only: const_get_index + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_simple, only: slp + + ! Local variables: + + integer :: const_index + integer :: errcode + logical :: const_is_dry + character(len=256) :: errmsg + type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) + character(len=*), parameter :: subname = "physics_history_init" + + call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') + call const_get_index('super_cool_cat_const', const_index, abort=.false., warning=.false.) + if (const_index >= 0) then + const_props_ptr => cam_model_const_properties() + call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg) + if (const_is_dry) then + call history_add_field('COOL_CAT', 'super_cool_cat_const', 'lev', 'avg', 'kg kg-1', mixing_ratio='dry') + else + call history_add_field('COOL_CAT', 'super_cool_cat_const', 'lev', 'avg', 'kg kg-1', mixing_ratio='wet') + end if + end if + + end subroutine physics_history_init + + subroutine physics_history_out() + use cam_ccpp_cap, only: cam_constituents_array + use cam_history, only: history_out_field + use cam_constituents, only: const_get_index + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use physics_types_simple, only: slp + + ! Local variables: + + !! Local variables + real(kind_phys), pointer :: const_data_ptr(:,:,:) + character(len=512) :: standard_name + integer :: const_index + character(len=*), parameter :: subname = "physics_history_out" + + call history_out_field('SLP', slp, size(slp, 1)) + call const_get_index('super_cool_cat_const', const_index, abort=.false., warning=.false.) + if (const_index >= 0) then + const_data_ptr => cam_constituents_array() + call history_out_field('COOL_CAT', const_data_ptr(:,:,const_index), size(const_data_ptr, 1)) + end if + + end subroutine physics_history_out + +end module physics_history_simple diff --git a/test/unit/sample_files/write_init_files/ddt2_reg.xml b/test/unit/sample_files/write_init_files/ddt2_reg.xml index 65f4e0c0..28bee48e 100644 --- a/test/unit/sample_files/write_init_files/ddt2_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt2_reg.xml @@ -7,16 +7,19 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp + horizontal_dimension slp sea_lev_pres + horizontal_dimension eddy_len + eddy_length_scale diff --git a/test/unit/sample_files/write_init_files/ddt_array_reg.xml b/test/unit/sample_files/write_init_files/ddt_array_reg.xml index 504cd880..a523cf1b 100644 --- a/test/unit/sample_files/write_init_files/ddt_array_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt_array_reg.xml @@ -12,6 +12,7 @@ units="Pa" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension slp sea_lev_pres + @@ -29,6 +30,7 @@ index_name="index_of_potential_temperature" index_pos="number_of_thermo_vars"> theta pot_temp + diff --git a/test/unit/sample_files/write_init_files/ddt_reg.xml b/test/unit/sample_files/write_init_files/ddt_reg.xml index 0ec3079e..831ee949 100644 --- a/test/unit/sample_files/write_init_files/ddt_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt_reg.xml @@ -7,11 +7,13 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp + horizontal_dimension slp sea_lev_pres + diff --git a/test/unit/sample_files/write_init_files/no_req_var_reg.xml b/test/unit/sample_files/write_init_files/no_req_var_reg.xml index 8546cf7e..59aec546 100644 --- a/test/unit/sample_files/write_init_files/no_req_var_reg.xml +++ b/test/unit/sample_files/write_init_files/no_req_var_reg.xml @@ -7,16 +7,19 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp + horizontal_dimension slp sea_lev_pres + horizontal_dimension eddy_len + diff --git a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml index e587e34c..9c88fd1f 100644 --- a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml +++ b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml @@ -1,10 +1,11 @@ TAG1 - + TAG2 - - + + + none diff --git a/test/unit/sample_files/write_init_files/simple_reg.xml b/test/unit/sample_files/write_init_files/simple_reg.xml index 94c4ae28..f7920068 100644 --- a/test/unit/sample_files/write_init_files/simple_reg.xml +++ b/test/unit/sample_files/write_init_files/simple_reg.xml @@ -12,6 +12,7 @@ units="Pa" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension slp sea_lev_pres + @@ -22,7 +23,9 @@ The coolest constituent imaginable + horizontal_dimension vertical_layer_dimension COOL_CAT cnst_COOL_CAT + diff --git a/test/unit/test_build_cache.py b/test/unit/test_build_cache.py index c3152367..4e12a680 100644 --- a/test/unit/test_build_cache.py +++ b/test/unit/test_build_cache.py @@ -423,11 +423,12 @@ def test_update_registry(self): #Set non-file update_registry inputs: ic_names = {"Only_had_a": ["heart", "brain"]} + diag_names = {"small_dog_wrt_dorothy": 'TOTO'} dycore = "banana" #Update registry fields: test_cache.update_registry(tmp_test_reg, [tmp_test_reg], - dycore, [tmp_test_reg], ic_names) + dycore, [tmp_test_reg], ic_names, diag_names) #Write updated fields to build cache file: test_cache.write() @@ -449,7 +450,6 @@ def test_registry_mismatch_good_match(self): function returns False when there is no change in the registry. """ - #Set path to already-existing cache file used by test_write_init_files: cache_file = os.path.join(_WRITE_INIT_DIR, "simple_build_cache_template.xml") diff --git a/test/unit/test_cam_autogen.py b/test/unit/test_cam_autogen.py index 58f54daa..deda626b 100644 --- a/test/unit/test_cam_autogen.py +++ b/test/unit/test_cam_autogen.py @@ -158,6 +158,12 @@ def ic_names(self): return {} + def diag_names(self): + + """Fake version of 'diag_names' property.""" + + return {} + # pylint: enable=no-self-use # pylint: enable=unused-argument @@ -515,7 +521,7 @@ def test_generate_registry(self): test_data_search = [os.path.join(_CAM_ROOT_DIR, "src", "data")] #Set expected output tuple: - expected_results = (f'{self.test_bldroot}'+os.sep+'cam_registry', False, [], {}) + expected_results = (f'{self.test_bldroot}'+os.sep+'cam_registry', False, [], {}, {}) #Run registry generation function: gen_results = generate_registry(test_data_search, self.test_cache, _CAM_ROOT_DIR, diff --git a/test/unit/test_registry.py b/test/unit/test_registry.py index 98d0a232..fcb19d04 100644 --- a/test/unit/test_registry.py +++ b/test/unit/test_registry.py @@ -94,7 +94,7 @@ def test_good_simple_registry(self): out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') remove_files([out_source, out_meta]) # Run test - retcode, files, _ = gen_registry(filename, 'fv', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'fv', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -136,7 +136,7 @@ def test_good_ddt_registry(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _ = gen_registry(filename, dycore, _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, dycore, _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -183,7 +183,7 @@ def test_good_ddt_registry2(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -223,7 +223,7 @@ def test_good_array(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -261,7 +261,7 @@ def test_good_metadata_file_registry(self): out_meta = os.path.join(_TMP_DIR, out_name + '.meta') remove_files([out_source, out_meta]) # generate registry - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -315,7 +315,7 @@ def test_diff_src_root_metadata_file_registry(self): shutil.copy(meta_file, tmp_src_dir) # Generate registry - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _TMP_DIR, loglevel=logging.ERROR, error_on_no_validate=True) @@ -372,7 +372,7 @@ def test_SourceMods_metadata_file_registry(self): shutil.copy(meta_file, source_mod_file) # Generate registry - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, tmp_src_dir, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -423,7 +423,7 @@ def test_good_complete_registry(self): remove_files([out_source, out_meta]) # Run test - retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -530,7 +530,7 @@ def test_parameter(self): # End for tree.write(filename) # Run test - retcode, files, _ = gen_registry(filename, 'eul', _TMP_DIR, 2, + retcode, files, _, _ = gen_registry(filename, 'eul', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) diff --git a/test/unit/test_write_hist_file.py b/test/unit/test_write_hist_file.py new file mode 100644 index 00000000..fbac4fb2 --- /dev/null +++ b/test/unit/test_write_hist_file.py @@ -0,0 +1,486 @@ +#! /usr/bin/env python3 +#----------------------------------------------------------------------- +# Description: Contains unit tests for testing CAM "physics_history" code +# generation using the registry and CCPP physics suites. +# +# Assumptions: +# +# Command line arguments: none +# +# Usage: python "test_write_hist_file.py" # run the unit tests +#----------------------------------------------------------------------- + +"""Test write_init_files in write_hist_file.py""" + +import sys +import os +import glob +import unittest +import filecmp +import logging + +__TEST_DIR = os.path.dirname(os.path.abspath(__file__)) +_CAM_ROOT = os.path.abspath(os.path.join(__TEST_DIR, os.pardir, os.pardir)) +__CCPP_DIR = os.path.join(_CAM_ROOT, "ccpp_framework", "scripts") +__REGISTRY_DIR = os.path.join(_CAM_ROOT, "src", "data") +_REG_SAMPLES_DIR = os.path.join(__TEST_DIR, "sample_files") +_HIST_SAMPLES_DIR = os.path.join(_REG_SAMPLES_DIR, "write_hist_file") +_INIT_SAMPLES_DIR = os.path.join(_REG_SAMPLES_DIR, "write_init_files") +_PRE_TMP_DIR = os.path.join(__TEST_DIR, "tmp") +_TMP_DIR = os.path.join(_PRE_TMP_DIR, "write_hist_file") +_SRC_MOD_DIR = os.path.join(_PRE_TMP_DIR, "SourceMods") +_INC_SEARCH_DIRS = [_SRC_MOD_DIR, __REGISTRY_DIR] + +__FILE_OPEN = (lambda x: open(x, 'r', encoding='utf-8')) + +#Check for all necessary directories: +if not os.path.exists(__CCPP_DIR): + EMSG = "Cannot find CCPP framework directory where 'ccpp_capgen.py' should be located." + raise ImportError(EMSG) + +if not os.path.exists(__REGISTRY_DIR): + EMSG = "Cannot find registry directory where 'write_hist_files.py' should be located." + raise ImportError(EMSG) + +if not os.path.exists(_REG_SAMPLES_DIR): + raise ImportError("Cannot find sample files directory") + +if not os.path.exists(_INIT_SAMPLES_DIR): + raise ImportError("Cannot find 'write_init_files' sample files directory") + +if not os.path.exists(_HIST_SAMPLES_DIR): + raise ImportError("Cannot find 'write_hist_file' sample files directory") + +#Add CCPP framework directory to python path to +#import capgen code generator: +sys.path.append(__CCPP_DIR) + +#Add registry directory to python path to import +#registry and 'phys_init' code generators: +sys.path.append(__REGISTRY_DIR) + +# pylint: disable=wrong-import-position +from ccpp_capgen import capgen +from framework_env import CCPPFrameworkEnv +from generate_registry_data import gen_registry +import write_hist_file as write_hist +# pylint: enable=wrong-import-position + +############################################################################### +def remove_files(file_list): +############################################################################### + """Remove files in if they exist""" + for fpath in file_list: + if os.path.exists(fpath): + os.remove(fpath) + # End if + # End for + +############################################################################### +def find_file(filename, search_dirs): +############################################################################### + """Look for in . + Return the found path and the match directory (from ). + """ + match_file = None + for sdir in search_dirs: + test_path = os.path.join(sdir, filename) + if os.path.exists(test_path): + match_file = test_path + break + # End if + # End for + return match_file + +############################################################################### + +class WriteHistTest(unittest.TestCase): + + """Tests for `write_hist_files`.""" + + @classmethod + def setUpClass(cls): + """Clean output directory (tmp) before running tests""" + # Does "tmp" directory exist? If not then create it: + if not os.path.exists(_PRE_TMP_DIR): + os.mkdir(_PRE_TMP_DIR) + # end if + # Now check if "write_init_files" directory exists: + if not os.path.exists(_TMP_DIR): + os.mkdir(_TMP_DIR) + # end if + # Finally check if "SourceMods" directory exists: + if not os.path.exists(_SRC_MOD_DIR): + os.mkdir(_SRC_MOD_DIR) + # end if + + # Clear out all files: + remove_files(glob.iglob(os.path.join(_TMP_DIR, '*.*'))) + + # Run inherited setup method: + super(cls, WriteHistTest).setUpClass() + + def test_simple_reg_write_hist(self): + """ + Test that the 'write_hist_files' function + generates the correct Fortran code given + a simple registry and CCPP physics suite with + only regular variables. + """ + + # Setup registry inputs: + filename = os.path.join(_INIT_SAMPLES_DIR, "simple_reg.xml") + out_source_name = "physics_types_simple" + out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') + out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') + + out_hist_name = "physics_history_simple.F90" + out_hist = os.path.join(_TMP_DIR, out_hist_name) + + # Setup capgen inputs: + model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") + sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") + scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust_cnst.meta") + cap_datafile = os.path.join(_TMP_DIR, "datatable_cnst.xml") + + host_files = [model_host, out_meta] + + # Setup comparison files + in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) + + # Create local logger: + logger = logging.getLogger("write_hist_file_simple") + + # Clear all temporary output files: + remove_files([out_source, cap_datafile, out_meta, out_hist]) + + # Generate registry files: + _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _SRC_MOD_DIR, _CAM_ROOT, + loglevel=logging.ERROR, + error_on_no_validate=True) + + # Generate CCPP capgen files: + kind_types = ['kind_phys=REAL64'] + run_env = CCPPFrameworkEnv(logger, host_files=host_files, + scheme_files=scheme_files, suites=sdf, + preproc_directives='', + generate_docfiles=False, + host_name='cam', kind_types=kind_types, + use_error_obj=False, + force_overwrite=True, + output_root=_TMP_DIR, + ccpp_datafile=cap_datafile) + + cap_database = capgen(run_env, return_db=True) + + # Generate physics initialization files: + retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, + find_file, _INC_SEARCH_DIRS, + 3, logger, + phys_hist_filename=out_hist_name) + + # Check return message: + amsg = f"Test failure: retmsg={retmsg}" + self.assertEqual(retmsg, '', msg=amsg) + + # Make sure each output file was created: + amsg = f"{out_hist} does not exist" + self.assertTrue(os.path.exists(out_hist), msg=amsg) + + # For each output file, make sure it matches input file + amsg = f"{in_hist} does not match {out_hist}" + self.assertTrue(filecmp.cmp(in_hist, out_hist, + shallow=False), msg=amsg) + + def test_no_reqvar_write_hist(self): + """ + Test that the 'write_hist_file' function + generates the correct Fortran code given + a CCPP physics suite with no required + variables from the registry. + """ + + # Setup registry inputs: + filename = os.path.join(_INIT_SAMPLES_DIR, "no_req_var_reg.xml") + out_source_name = "physics_types_no_req_var" + out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') + out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') + out_hist_name = "physics_history_no_req_var.F90" + out_hist = os.path.join(_TMP_DIR, out_hist_name) + + # Setup capgen inputs: + model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") + sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") + scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust_noreq.meta") + cap_datafile = os.path.join(_TMP_DIR, "datatable_no_req_var.xml") + + host_files = [model_host, out_meta] + + # Setup write_init_files inputs: + in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) + + # Create local logger: + logger = logging.getLogger("write_hist_file_noreq") + + # Clear all temporary output files: + remove_files([out_source, out_meta, cap_datafile, + out_hist]) + + # Generate registry files: + _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _SRC_MOD_DIR, _CAM_ROOT, + loglevel=logging.ERROR, + error_on_no_validate=True) + + # Generate CCPP capgen files: + kind_types = ['kind_phys=REAL64'] + run_env = CCPPFrameworkEnv(logger, host_files=host_files, + scheme_files=scheme_files, suites=sdf, + preproc_directives='', + generate_docfiles=False, + host_name='cam', kind_types=kind_types, + use_error_obj=False, + force_overwrite=True, + output_root=_TMP_DIR, + ccpp_datafile=cap_datafile) + + cap_database = capgen(run_env, return_db=True) + + # Generate physics initialization files: + retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, + find_file, _INC_SEARCH_DIRS, + 3, logger, + phys_hist_filename=out_hist_name) + + # Check return message: + amsg = f"Test failure: retmsg={retmsg}" + self.assertEqual(retmsg, '', msg=amsg) + + # Make sure each output file was created: + amsg = f"{out_hist} does not exist" + self.assertTrue(os.path.exists(out_hist), msg=amsg) + + # For each output file, make sure it matches input file + amsg = f"{out_hist} does not match {out_hist}" + self.assertTrue(filecmp.cmp(in_hist, out_hist, + shallow=False), msg=amsg) + + + def test_ddt_reg_write_init(self): + """ + Test that the 'write_hist_file' function + generates the correct Fortran code given + a registry which contains variables and + a DDT. + """ + + # Setup registry inputs: + filename = os.path.join(_INIT_SAMPLES_DIR, "ddt_reg.xml") + out_source_name = "physics_types_ddt" + out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') + out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') + out_hist_name = 'physics_history_ddt.F90' + out_hist = os.path.join(_TMP_DIR, out_hist_name) + + # Setup capgen inputs: + model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") + sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") + scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") + cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt.xml") + + host_files = [model_host, out_meta] + + # Setup write_init_files inputs: + in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) + + # Create local logger: + logger = logging.getLogger("write_hist_file_ddt") + + # Clear all temporary output files: + remove_files([out_source, out_meta, cap_datafile, out_hist]) + + # Generate registry files: + _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _SRC_MOD_DIR, _CAM_ROOT, + loglevel=logging.ERROR, + error_on_no_validate=True) + + # Generate CCPP capgen files: + kind_types=['kind_phys=REAL64'] + run_env = CCPPFrameworkEnv(logger, host_files=host_files, + scheme_files=scheme_files, suites=sdf, + preproc_directives='', + generate_docfiles=False, + host_name='cam', kind_types=kind_types, + use_error_obj=False, + force_overwrite=True, + output_root=_TMP_DIR, + ccpp_datafile=cap_datafile) + cap_database = capgen(run_env, return_db=True) + + # Generate physics initialization files: + retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, + find_file, _INC_SEARCH_DIRS, + 3, logger, + phys_hist_filename=out_hist_name) + + # Check return code: + amsg = f"Test failure: retmsg={retmsg}" + self.assertEqual(retmsg, '', msg=amsg) + + # Make sure each output file was created: + amsg = f"{out_hist} does not exist" + self.assertTrue(os.path.exists(out_hist), msg=amsg) + + # For each output file, make sure it matches input file + amsg = f"{out_hist} does not match {in_hist}" + self.assertTrue(filecmp.cmp(in_hist, out_hist, + shallow=False), msg=amsg) + + def test_ddt2_reg_write_init(self): + """ + Test that the 'write_init_files' function + generates the correct Fortran code given + a registry that contains variables and + a DDT, which itself contains another DDT. + """ + + # Setup registry inputs: + filename = os.path.join(_INIT_SAMPLES_DIR, "ddt2_reg.xml") + out_source_name = "physics_types_ddt2" + out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') + out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') + out_hist_name = "physics_history_ddt2.F90" + out_hist = os.path.join(_TMP_DIR, out_hist_name) + + # Setup capgen inputs: + model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") + sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") + scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") + cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt2.xml") + + host_files = [model_host, out_meta] + + # Comparison files + in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) + + # Create local logger: + logger = logging.getLogger("write_hist_file_ddt2") + + # Clear all temporary output files: + remove_files([out_source, out_meta, cap_datafile, out_hist]) + + # Generate registry files: + _, files, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _SRC_MOD_DIR, _CAM_ROOT, + loglevel=logging.ERROR, + error_on_no_validate=True) + + # Generate CCPP capgen files: + kind_types=['kind_phys=REAL64'] + run_env = CCPPFrameworkEnv(logger, host_files=host_files, + scheme_files=scheme_files, suites=sdf, + preproc_directives='', + generate_docfiles=False, + host_name='cam', kind_types=kind_types, + use_error_obj=False, + force_overwrite=True, + output_root=_TMP_DIR, + ccpp_datafile=cap_datafile) + cap_database = capgen(run_env, return_db=True) + + # Generate physics initialization files: + retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, + find_file, _INC_SEARCH_DIRS, + 3, logger, + phys_hist_filename=out_hist_name) + + # Check return code: + amsg = f"Test failure: retmsg={retmsg}" + self.assertEqual(retmsg, '', msg=amsg) + + # Make sure each output file was created: + amsg = f"{out_hist} does not exist" + self.assertTrue(os.path.exists(out_hist), msg=amsg) + + # For each output file, make sure it matches input file + amsg = f"{out_hist} does not match {in_hist}" + self.assertTrue(filecmp.cmp(out_hist, in_hist, + shallow=False), msg=amsg) + + def test_ddt_array_reg_write_init(self): + """ + Test that the 'write_hist_files' function + generates the correct Fortran code given + a registry which contains Array variables + and a DDT. + """ + + # Setup registry inputs: + filename = os.path.join(_INIT_SAMPLES_DIR, "ddt_array_reg.xml") + out_source_name = "physics_types_ddt_array" + out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') + out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') + out_hist_name = "physics_history_ddt_array.F90" + out_hist = os.path.join(_TMP_DIR, out_hist_name) + + # Setup capgen inputs: + model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") + sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") + scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") + cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt_array.xml") + + host_files = [model_host, out_meta] + + # Setup write_init_files inputs: + in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) + + # Create local logger: + logger = logging.getLogger("write_hist_file_ddt_array") + + # Clear all temporary output files: + remove_files([out_source, out_meta, cap_datafile, out_hist]) + + # Generate registry files: + _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _SRC_MOD_DIR, _CAM_ROOT, + loglevel=logging.ERROR, + error_on_no_validate=True) + + # Generate CCPP capgen files: + kind_types=['kind_phys=REAL64'] + run_env = CCPPFrameworkEnv(logger, host_files=host_files, + scheme_files=scheme_files, suites=sdf, + preproc_directives='', + generate_docfiles=False, + host_name='cam', kind_types=kind_types, + use_error_obj=False, + force_overwrite=True, + output_root=_TMP_DIR, + ccpp_datafile=cap_datafile) + cap_database = capgen(run_env, return_db=True) + + # Generate physics initialization files: + retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, + find_file, _INC_SEARCH_DIRS, + 3, logger, + phys_hist_filename=out_hist_name) + + # Check return code: + amsg = f"Test failure: retmsg={retmsg}" + self.assertEqual(retmsg, '', msg=amsg) + + # Make sure each output file was created: + amsg = f"{out_hist} does not exist" + self.assertTrue(os.path.exists(out_hist), msg=amsg) + + # For each output file, make sure it matches input file + amsg = f"{out_hist} does not match {in_hist}" + self.assertTrue(filecmp.cmp(out_hist, in_hist, + shallow=False), msg=amsg) + +########## + +if __name__ == '__main__': + unittest.main() diff --git a/test/unit/test_write_init_files.py b/test/unit/test_write_init_files.py index d0736ee0..7c57cdf2 100644 --- a/test/unit/test_write_init_files.py +++ b/test/unit/test_write_init_files.py @@ -238,7 +238,7 @@ def test_simple_reg_constituent_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, _, ic_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _, _, ic_names, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -403,7 +403,7 @@ def test_protected_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -572,7 +572,7 @@ def test_no_horiz_var_write_init(self): remove_files([out_source, out_meta, cap_datafile, check_init_out, phys_input_out]) # Generate registry files: - _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -647,7 +647,7 @@ def test_scalar_var_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -722,7 +722,7 @@ def test_4d_var_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -878,7 +878,7 @@ def test_ddt2_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -959,7 +959,7 @@ def test_ddt_array_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, _, ic_names = gen_registry(filename, 'se', _TMP_DIR, 3, + _, _, ic_names, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) From abf329a255cf4c930f1bcee412f5a4bed8262236 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 10 Jun 2024 00:09:23 -0600 Subject: [PATCH 26/79] enable avg flags in registry; clear buffers --- cime_config/cam_build_cache.py | 8 +- src/data/generate_registry_data.py | 29 ++++- src/data/registry.xml | 36 ++--- src/data/registry_v1_0.xsd | 7 + src/data/write_hist_file.py | 15 ++- src/history/cam_hist_file.F90 | 118 +++++++++++------ src/history/cam_history.F90 | 11 +- src/utils/cam_grid_support.F90 | 123 ++++++++++++++++++ test/run_tests.sh | 2 + .../update_reg_build_cache.xml | 2 +- .../write_hist_file/physics_history_ddt.F90 | 4 +- .../write_hist_file/physics_history_ddt2.F90 | 4 +- .../physics_history_ddt_array.F90 | 8 +- .../physics_history_simple.F90 | 4 +- .../write_init_files/ddt_array_reg.xml | 4 +- test/unit/test_build_cache.py | 2 +- test/unit/test_write_hist_file.py | 2 +- 17 files changed, 286 insertions(+), 93 deletions(-) diff --git a/cime_config/cam_build_cache.py b/cime_config/cam_build_cache.py index 83f304e2..8106fbc9 100644 --- a/cime_config/cam_build_cache.py +++ b/cime_config/cam_build_cache.py @@ -259,7 +259,8 @@ def __init__(self, build_cache): self.__ic_names[stdname].append(itext) elif item.tag == 'diagnostic_name': stdname = item.get('standard_name') - self.__diag_names[stdname] = clean_xml_text(item) + flag = item.get('flag') + self.__diag_names[stdname] = (clean_xml_text(item), flag) else: emsg = "ERROR: Unknown registry tag, '{}'" raise ValueError(emsg.format(item.tag)) @@ -421,10 +422,11 @@ def write(self): ic_entry.text = ic_name # end for # end for - for stdname, diag_name in self.__diag_names.items(): + for stdname, diag_info in self.__diag_names.items(): diag_entry = ET.SubElement(registry, 'diagnostic_name') diag_entry.set('standard_name', stdname) - diag_entry.text = diag_name + diag_entry.set('flag', diag_info[1]) + diag_entry.text = diag_info[0] # end for # CCPP ccpp = ET.SubElement(new_cache, 'CCPP') diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index fea6be1d..1f530c48 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -156,6 +156,7 @@ def __init__(self, elem_node, local_name, dimensions, known_types, self.__initial_val_vars = set() self.__ic_names = None self.__diagnostic_name = None + self.__diagnostic_flag = None self.__elements = [] self.__protected = protected self.__index_name = index_name @@ -189,6 +190,11 @@ def __init__(self, elem_node, local_name, dimensions, known_types, self.__ic_names = [x.strip() for x in attrib.text.split(' ') if x] elif attrib.tag == 'diagnostic': self.__diagnostic_name = attrib.attrib['name'] + if 'flag' in attrib.attrib: + self.__diagnostic_flag = attrib.attrib['flag'] + else: + self.__diagnostic_flag = 'avg' + # end if # end if (just ignore other tags) # end for if ((not self.initial_value) and @@ -335,6 +341,11 @@ def diagnostic_name(self): """Return the diagnostic name for this variable""" return self.__diagnostic_name + @property + def diagnostic_flag(self): + """Return the diagnostic flag for this variable""" + return self.__diagnostic_flag + @property def long_name(self): """Return the long_name for this variable""" @@ -1746,7 +1757,7 @@ def _create_ic_name_dict(registry): ############################################################################### def _create_diag_name_dict(registry): ############################################################################### - """ Build a dictionary of diagnostic names (key = standard_name) + """ Build a dictionary of diagnostic names and flags (key = standard_name) If this property is ever included in CCPP metadata, this section can be replaced by accessing the new metadata property and this routine will no longer be needed. @@ -1760,10 +1771,16 @@ def _create_diag_name_dict(registry): if obj.tag == 'variable': for attrib in obj: if attrib.tag == 'diagnostic': + diags = {} stdname = obj.get('standard_name') diag_name = attrib.attrib['name'] # peverwhee - duplicate check? - diag_name_dict[stdname] = diag_name + if 'flag' in attrib.attrib: + flag = attrib.attrib['flag'] + else: + flag = 'avg' + # end if + diag_name_dict[stdname] = (diag_name, flag) # end if # end for elif obj.tag == 'array': @@ -1771,10 +1788,16 @@ def _create_diag_name_dict(registry): if subobj.tag == 'element': for attrib in subobj: if attrib.tag == 'diagnostic': + diags = {} stdname = subobj.get('standard_name') diag_name = attrib.attrib['name'] # peverwhee - duplicate check? - diag_name_dict[stdname] = diag_name + if 'flag' in attrib.attrib: + flag = attrib.attrib['flag'] + else: + flag = 'avg' + # end if + diag_name_dict[stdname] = (diag_name, flag) # end if # end for # end if diff --git a/src/data/registry.xml b/src/data/registry.xml index d9a9648a..35fae500 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -30,21 +30,21 @@ allocatable="pointer"> horizontal_dimension ps state_ps - + horizontal_dimension psdry state_psdry - + horizontal_dimension phis state_phis - + Air temperature horizontal_dimension vertical_layer_dimension T state_t - + Horizontal wind in a direction perpendicular to northward_wind horizontal_dimension vertical_layer_dimension u state_u - + Horizontal wind in a direction perpendicular to eastward_wind horizontal_dimension vertical_layer_dimension v state_v - + horizontal_dimension vertical_layer_dimension s state_s - + Vertical pressure velocity horizontal_dimension vertical_layer_dimension omega state_omega - + horizontal_dimension vertical_layer_dimension pmid state_pmid - + horizontal_dimension vertical_layer_dimension pdeldry state_pdeldry - + horizontal_dimension vertical_interface_dimension zi state_zi - + Change in temperature from a parameterization horizontal_dimension vertical_layer_dimension dTdt tend_dtdt - + Change in eastward wind from a parameterization horizontal_dimension vertical_layer_dimension dudt tend_dudt - + Change in northward wind from a parameterization horizontal_dimension vertical_layer_dimension dvdt tend_dvdt - + Water vapor mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension Q cnst_Q - + Cloud water mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension CLDLIQ cnst_CLDLIQ - + Cloud ice mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension CLDICE cnst_CLDICE - + rain mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension RAINQM cnst_RAINQM - + diff --git a/src/data/registry_v1_0.xsd b/src/data/registry_v1_0.xsd index 2f7b6a92..38a7b336 100644 --- a/src/data/registry_v1_0.xsd +++ b/src/data/registry_v1_0.xsd @@ -98,6 +98,12 @@ + + + + + + @@ -149,6 +155,7 @@ + diff --git a/src/data/write_hist_file.py b/src/data/write_hist_file.py index 8441b313..ea9bc422 100644 --- a/src/data/write_hist_file.py +++ b/src/data/write_hist_file.py @@ -483,7 +483,8 @@ def write_physics_history_init_subroutine(outfile, host_dict, host_vars, host_im continue # end if - diag_name = diag_dict[var_stdname] + diag_name = diag_dict[var_stdname][0] + diag_flag = diag_dict[var_stdname][1] # Ignore any variable that is listed as a constiutuent, # as they will be handled separately by the constituents object: @@ -494,16 +495,16 @@ def write_physics_history_init_subroutine(outfile, host_dict, host_vars, host_im outfile.write("call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg)", 3) outfile.write("if (const_is_dry) then", 3) outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ - f"{vdim}, 'avg', '{var_units}', mixing_ratio='dry')" + f"{vdim}, '{diag_flag}', '{var_units}', mixing_ratio='dry')" outfile.write(outstr, 4) outfile.write("else", 3) outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ - f"{vdim}, 'avg', '{var_units}', mixing_ratio='wet')" + f"{vdim}, '{diag_flag}', '{var_units}', mixing_ratio='wet')" outfile.write(outstr, 4) outfile.write("end if", 3) outfile.write("end if", 2) else: - outstr = f"call history_add_field('{diag_name}', '{var_stdname}', {vdim}, 'avg', '{var_units}')" + outstr = f"call history_add_field('{diag_name}', '{var_stdname}', {vdim}, '{diag_flag}', '{var_units}')" outfile.write(outstr, 2) # end if # end for @@ -567,7 +568,7 @@ def write_physics_history_out_subroutine(outfile, host_dict, host_vars, host_imp continue # end if - diag_name = diag_dict[var_stdname] + diag_name = diag_dict[var_stdname][0] # Ignore any variable that is listed as a constiutuent, # as they will be handled separately by the constituents object: @@ -575,11 +576,11 @@ def write_physics_history_out_subroutine(outfile, host_dict, host_vars, host_imp outfile.write(f"call const_get_index('{var_stdname}', const_index, abort=.false., warning=.false.)", 2) outfile.write("if (const_index >= 0) then", 2) outfile.write("const_data_ptr => cam_constituents_array()", 3) - outstr = f"call history_out_field('{diag_name}', const_data_ptr(:,:,const_index), size(const_data_ptr, 1))" + outstr = f"call history_out_field('{diag_name}', const_data_ptr(:,:,const_index))" outfile.write(outstr, 3) outfile.write("end if", 2) else: - outstr = f"call history_out_field('{diag_name}', {var_locname}, size({var_locname}, 1))" + outstr = f"call history_out_field('{diag_name}', {var_locname})" outfile.write(outstr, 2) # end if # end for diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index a335165f..62d4ab20 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -118,6 +118,7 @@ module cam_hist_file procedure :: write_time_dependent_variables => config_write_time_dependent_variables procedure :: write_field => config_write_field procedure :: close_files => config_close_files + procedure :: clear_buffers => config_clear_buffers end type hist_file_t private :: count_array ! Number of non-blank strings in array @@ -597,7 +598,7 @@ subroutine config_set_up_fields(this, possible_field_list) use hist_api, only: hist_new_field, hist_new_buffer use hist_hashable, only: hist_hashable_t use cam_grid_support, only: cam_grid_num_grids - use hist_msg_handler, only: hist_have_error, hist_log_messages + use hist_msg_handler, only: hist_log_messages use cam_history_support, only: max_chars use cam_logfile, only: iulog use spmd_utils, only: masterproc @@ -625,7 +626,6 @@ subroutine config_set_up_fields(this, possible_field_list) character(len=128) :: errmsg type(hist_log_messages) :: errors - allocate(possible_grids(cam_grid_num_grids() + 1), stat=ierr) call check_allocate(ierr, subname, 'possible_grids', & file=__FILE__, line=__LINE__-1) @@ -642,7 +642,6 @@ subroutine config_set_up_fields(this, possible_field_list) write(errmsg,'(3a)') 'ERROR Field : ',trim(this%field_names(idx)),' not available' call endrun(subname//errmsg, file=__FILE__, line=__LINE__) end select - ! peverwhee - TODO: check for duplicate field ? call field_ptr%dimensions(dimensions) call field_ptr%shape(field_shape) call field_ptr%beg_dims(beg_dim) @@ -658,11 +657,11 @@ subroutine config_set_up_fields(this, possible_field_list) if (masterproc) then call errors%output(iulog) end if - call hist_new_buffer(field_info, field_shape, & - this%rl_kind, 1, this%accumulate_types(idx), 1) + ! peverwhee - TODO: create additional buffer(s) for other accum types +! call hist_new_buffer(field_info, field_shape, & +! this%rl_kind, 1, this%accumulate_types(idx), 1) ! Add to field list array and hash table this%field_list(idx) = field_info -! call this%add_to_field_list(field_info, this%accumulate_types(idx)) call this%field_list_hash_table%add_hash_key(field_info) ! Add grid to possible grids if it's not already there do grid_idx = 1, size(possible_grids, 1) @@ -690,6 +689,9 @@ subroutine config_set_up_fields(this, possible_field_list) do grid_idx = 1, num_grids this%grids(grid_idx) = possible_grids(grid_idx) end do + ! We don't need the user-set fields arrays anymore + deallocate(this%accumulate_types) + deallocate(this%field_names) end subroutine config_set_up_fields @@ -707,18 +709,16 @@ subroutine config_find_in_field_list(this, diagnostic_name, field_info, errmsg) class(hist_field_info_t), pointer :: field_ptr class(hist_hashable_t), pointer :: field_ptr_entry integer :: field_idx - character(len=3) :: accum_flag logical :: found_field character(len=*), parameter :: subname = 'hist:find_in_field_list: ' nullify(field_info) errmsg = '' found_field = .false. - ! Loop over field names - do field_idx = 1, size(this%field_names, 1) - if (this%field_names(field_idx) == trim(diagnostic_name)) then + ! Loop over fields + do field_idx = 1, size(this%field_list, 1) + if (trim(this%field_list(field_idx)%diag_name()) == trim(diagnostic_name)) then ! Grab the associated accumulate flag - accum_flag = this%accumulate_types(field_idx) found_field = .true. end if end do @@ -1336,7 +1336,6 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) is_initfile = (this%hfile_type == hfile_type_init_value) is_satfile = (this%hfile_type == hfile_type_sat_track) - ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%ndcurid,(/start/),(/count1/),(/ndcur/)) call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "ndcur" variable') ierr = pio_put_var (this%hist_files(instantaneous_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) @@ -1420,7 +1419,7 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) split_file_index == instantaneous_file_index .and. .not. restart) then cycle end if - call this%write_field(field_idx, split_file_index, restart, start) + call this%write_field(this%field_list(field_idx), split_file_index, restart, start) end do end do call t_stopf ('write_field') @@ -1429,24 +1428,27 @@ end subroutine config_write_time_dependent_variables ! ======================================================================== - subroutine config_write_field(this, field_index, split_file_index, restart, & + subroutine config_write_field(this, field, split_file_index, restart, & sample_index) use pio, only: PIO_OFFSET_KIND, pio_setframe use cam_history_support, only: hist_coords use hist_buffer, only: hist_buffer_t use hist_api, only: hist_buffer_norm_value use cam_grid_support, only: cam_grid_write_dist_array - use cam_abortutils, only: check_allocate + use cam_abortutils, only: check_allocate, endrun + use hist_field, only: hist_field_info_t ! Dummy arguments - class(hist_file_t), intent(inout) :: this - integer, intent(in) :: field_index - integer, intent(in) :: split_file_index - logical, intent(in) :: restart - integer, intent(in) :: sample_index + class(hist_file_t), intent(inout) :: this + type(hist_field_info_t), intent(inout) :: field +! integer, intent(in) :: field_index + integer, intent(in) :: split_file_index + logical, intent(in) :: restart + integer, intent(in) :: sample_index ! Local variables integer, allocatable :: field_shape(:) ! Field file dim sizes integer :: frank ! Field file rank + integer :: field_shape_temp integer, allocatable :: dimind(:) integer, allocatable :: dim_sizes(:) integer, allocatable :: beg_dims(:) @@ -1456,6 +1458,7 @@ subroutine config_write_field(this, field_index, split_file_index, restart, & integer :: field_decomp integer :: num_dims integer :: idx + integer :: dim_size_temp logical :: index_map(3) real(r8), allocatable :: field_data(:,:) class(hist_buffer_t), pointer :: buff_ptr @@ -1463,39 +1466,42 @@ subroutine config_write_field(this, field_index, split_file_index, restart, & !!! Get the field's shape and decomposition ! Shape on disk - call this%field_list(field_index)%shape(field_shape) + call field%shape(field_shape) frank = size(field_shape) - allocate(field_data(field_shape(1), field_shape(2)), stat=ierr) - call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) + if (frank == 1) then + allocate(field_data(field_shape(1), 1), stat=ierr) + call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) + else + allocate(field_data(field_shape(1), field_shape(2)), stat=ierr) + call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) + end if ! Shape of array - call this%field_list(field_index)%dimensions(dimind) + call field%dimensions(dimind) - call this%field_list(field_index)%beg_dims(beg_dims) - call this%field_list(field_index)%end_dims(end_dims) + call field%beg_dims(beg_dims) + call field%end_dims(end_dims) allocate(dim_sizes(size(beg_dims)), stat=ierr) call check_allocate(ierr, subname, 'dim_sizes', file=__FILE__, line=__LINE__-1) do idx = 1, size(beg_dims) dim_sizes(idx) = end_dims(idx) - beg_dims(idx) + 1 end do - num_dims = 0 - index_map = .false. - do idx = 1, size(beg_dims) - if ((end_dims(idx) - beg_dims(idx)) > 1) then - num_dims = num_dims + 1 - index_map(idx) = .true. - end if - end do - field_decomp = this%field_list(field_index)%decomp() + field_decomp = field%decomp() num_patches = 1 do patch_idx = 1, num_patches - varid = this%field_list(field_index)%varid(patch_idx) + varid = field%varid(patch_idx) call pio_setframe(this%hist_files(split_file_index), varid, int(sample_index,kind=PIO_OFFSET_KIND)) - buff_ptr => this%field_list(field_index)%buffers - call hist_buffer_norm_value(buff_ptr, field_data) - call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1:frank), & - field_shape(1:frank), field_data, varid) + buff_ptr => field%buffers + if (frank == 1) then + call hist_buffer_norm_value(buff_ptr, field_data(:,1)) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1: frank), & + field_shape, field_data(:,1), varid) + else + call hist_buffer_norm_value(buff_ptr, field_data) + call cam_grid_write_dist_array(this%hist_files(split_file_index), field_decomp, dim_sizes(1: frank), & + field_shape, field_data, varid) + end if end do end subroutine config_write_field @@ -1540,6 +1546,28 @@ end subroutine config_close_files ! ======================================================================== + subroutine config_clear_buffers(this) + use hist_msg_handler, only: hist_log_messages + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + ! Local variables + integer :: field_idx + type(hist_log_messages) :: errors + + + do field_idx = 1, size(this%field_list) + call this%field_list(field_idx)%clear_buffers(logger=errors) + if (masterproc) then + call errors%output(iulog) + end if + end do + + end subroutine config_clear_buffers + + ! ======================================================================== + integer function count_array(arr_in) ! Dummy argument character(len=*), intent(in) :: arr_in(:) @@ -1673,24 +1701,32 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & end if num_fields = count_array(hist_avg_fields) if (num_fields > 0) then + call endrun(subname//"ERROR, average fields not yet implemented", & + file=__FILE__, line=__LINE__) has_acc = .true. call MPI_Bcast(hist_avg_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_min_fields) if (num_fields > 0) then + call endrun(subname//"ERROR, minimum fields not yet implemented", & + file=__FILE__, line=__LINE__) has_acc = .true. call MPI_Bcast(hist_min_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_max_fields) if (num_fields > 0) then + call endrun(subname//"ERROR, maximum fields not yet implemented", & + file=__FILE__, line=__LINE__) has_acc = .true. call MPI_Bcast(hist_max_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if num_fields = count_array(hist_var_fields) if (num_fields > 0) then + call endrun(subname//"ERROR, standard deviation fields not yet implemented", & + file=__FILE__, line=__LINE__) has_acc = .true. call MPI_Bcast(hist_var_fields(:), num_fields, MPI_CHARACTER, & masterprocid, mpicom, ierr) @@ -1926,7 +1962,7 @@ subroutine hist_read_namelist_config(filename, config_arr) end if allocate(config_arr(num_configs), stat=ierr, errmsg=errmsg) call check_allocate(ierr, subname, 'config_arr', & - file=__FILE__, line=__LINE__-2) + file=__FILE__, line=__LINE__-1) ! This block is needed for testing if (ierr /= 0) then return diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 86f87959..f72d4fcc 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -568,7 +568,7 @@ end subroutine history_add_field_nd !=========================================================================== - subroutine history_out_field_1d(diagnostic_name, field_values, idim) + subroutine history_out_field_1d(diagnostic_name, field_values) !----------------------------------------------------------------------- ! ! Purpose: Accumulate active fields - 1d fields @@ -582,7 +582,6 @@ subroutine history_out_field_1d(diagnostic_name, field_values, idim) use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name - integer, intent(in) :: idim real(r8), intent(in) :: field_values(:) ! Local variables @@ -618,7 +617,7 @@ end subroutine history_out_field_1d !=========================================================================== - subroutine history_out_field_2d(diagnostic_name, field_values, idim) + subroutine history_out_field_2d(diagnostic_name, field_values) !----------------------------------------------------------------------- ! ! Purpose: Accumulate active fields - 2d fields @@ -632,7 +631,6 @@ subroutine history_out_field_2d(diagnostic_name, field_values, idim) use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name - integer, intent(in) :: idim real(r8), intent(in) :: field_values(:,:) ! Local variables @@ -667,7 +665,7 @@ end subroutine history_out_field_2d !=========================================================================== - subroutine history_out_field_3d(diagnostic_name, field_values, idim) + subroutine history_out_field_3d(diagnostic_name, field_values) !----------------------------------------------------------------------- ! ! Purpose: Accumulate active fields - 3d fields @@ -680,7 +678,6 @@ subroutine history_out_field_3d(diagnostic_name, field_values, idim) use shr_kind_mod, only: r8 => shr_kind_r8 ! Dummy variables character(len=*), intent(in) :: diagnostic_name - integer, intent(in) :: idim real(r8), intent(in) :: field_values(:,:,:) ! Local variables @@ -692,6 +689,7 @@ subroutine history_out_field_3d(diagnostic_name, field_values, idim) class(hist_field_info_t), pointer :: field_info errmsg = '' + call endrun('ERROR: '//subname//'3d history fields not implemented', file=__FILE__, line=__LINE__) do file_idx = 1, size(hist_configs, 1) ! Check if the field is on the current file @@ -800,6 +798,7 @@ subroutine history_wrap_up(restart_write, last_timestep) write(iulog,9004) end if end if + call hist_configs(file_idx)%clear_buffers() end do 9003 format(' Output at NSTEP = ',i10,/, & ' Number of time samples on this file = ',i10,/, & diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index 32c7b8db..ec032bea 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -189,8 +189,10 @@ module cam_grid_support procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int + procedure :: write_darray_1d_double => cam_grid_write_darray_1d_double procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double + procedure :: write_darray_1d_real => cam_grid_write_darray_1d_real procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real end type cam_grid_t @@ -352,8 +354,10 @@ end subroutine print_attr_spec interface cam_grid_write_dist_array module procedure cam_grid_write_dist_array_2d_int module procedure cam_grid_write_dist_array_3d_int + module procedure cam_grid_write_dist_array_1d_double module procedure cam_grid_write_dist_array_2d_double module procedure cam_grid_write_dist_array_3d_double + module procedure cam_grid_write_dist_array_1d_real module procedure cam_grid_write_dist_array_2d_real module procedure cam_grid_write_dist_array_3d_real end interface @@ -1318,6 +1322,38 @@ subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, hbuf, varid) end subroutine cam_grid_write_dist_array_3d_int + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_1d_double + ! + ! Interface function for the grid%write_darray_1d_double method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_1d_double(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_1d_double(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_1d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_1d_double + !--------------------------------------------------------------------------- ! ! cam_grid_write_dist_array_2d_double @@ -1382,6 +1418,39 @@ subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, hbuf, var end subroutine cam_grid_write_dist_array_3d_double + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_dist_array_1d_real + ! + ! Interface function for the grid%write_darray_1d_real method + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_dist_array_1d_real(File, id, adims, fdims, hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + write(iulog,*) gridid + if (gridid > 0) then + call cam_grids(gridid)%write_darray_1d_real(File, adims, fdims, hbuf, varid) + else + write(errormsg, *) 'cam_grid_write_dist_array_1d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_1d_real + !--------------------------------------------------------------------------- ! ! cam_grid_write_dist_array_2d_real @@ -3390,6 +3459,33 @@ subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, hbuf, varid) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_int: Error writing variable') end subroutine cam_grid_write_darray_3d_int + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_1d_double: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_1d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_1d_double: Error writing variable') + end subroutine cam_grid_write_darray_1d_double + !--------------------------------------------------------------------------- ! ! cam_grid_write_darray_2d_double: Write a variable defined on this grid @@ -3445,6 +3541,33 @@ subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, hbuf, varid end subroutine cam_grid_write_darray_3d_double + !--------------------------------------------------------------------------- + ! + ! cam_grid_write_darray_2d_real: Write a variable defined on this grid + ! + !--------------------------------------------------------------------------- + subroutine cam_grid_write_darray_1d_real(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, 'cam_grid_write_darray_1d_real: Error writing variable') + end subroutine cam_grid_write_darray_1d_real + !--------------------------------------------------------------------------- ! ! cam_grid_write_darray_2d_real: Write a variable defined on this grid diff --git a/test/run_tests.sh b/test/run_tests.sh index 874d72d8..d92a248a 100755 --- a/test/run_tests.sh +++ b/test/run_tests.sh @@ -78,6 +78,8 @@ run_unittest test/unit/test_registry.py run_unittest test/unit/test_create_readnl_files.py # Physics variable init (phys_init) generator unit tests: run_unittest test/unit/test_write_init_files.py +# Physics variable history generator unit tests: +run_unittest test/unit/test_write_hist_file.py # ParamGen atm_in namelist writer unit tests: run_unittest test/unit/test_atm_in_paramgen.py # CAM history config unit tests diff --git a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml index 5e5b19af..54ba7645 100644 --- a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml @@ -9,7 +9,7 @@ tmp/cam_build_cache/test_reg.xml heart brain - TOTO + TOTO diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 index 8f796bdc..355122bb 100644 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 @@ -66,8 +66,8 @@ subroutine physics_history_out() integer :: const_index character(len=*), parameter :: subname = "physics_history_out" - call history_out_field('THETA', phys_state%theta, size(phys_state%theta, 1)) - call history_out_field('SLP', slp, size(slp, 1)) + call history_out_field('THETA', phys_state%theta) + call history_out_field('SLP', slp) end subroutine physics_history_out diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 index 010de78a..380b116a 100644 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 @@ -66,8 +66,8 @@ subroutine physics_history_out() integer :: const_index character(len=*), parameter :: subname = "physics_history_out" - call history_out_field('THETA', phys_state%theta, size(phys_state%theta, 1)) - call history_out_field('SLP', phys_state%slp, size(phys_state%slp, 1)) + call history_out_field('THETA', phys_state%theta) + call history_out_field('SLP', phys_state%slp) end subroutine physics_history_out diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 index 7e630d88..e6b3b0e1 100644 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 +++ b/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 @@ -45,8 +45,8 @@ subroutine physics_history_init() type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) character(len=*), parameter :: subname = "physics_history_init" - call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') - call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') + call history_add_field('THETA', 'potential_temperature', 'lev', 'lst', 'K') + call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'lst', 'Pa') end subroutine physics_history_init @@ -66,8 +66,8 @@ subroutine physics_history_out() integer :: const_index character(len=*), parameter :: subname = "physics_history_out" - call history_out_field('THETA', phys_state%T(:, :, ix_theta), size(phys_state%T(:, :, ix_theta), 1)) - call history_out_field('SLP', phys_state%slp, size(phys_state%slp, 1)) + call history_out_field('THETA', phys_state%T(:, :, ix_theta)) + call history_out_field('SLP', phys_state%slp) end subroutine physics_history_out diff --git a/test/unit/sample_files/write_hist_file/physics_history_simple.F90 b/test/unit/sample_files/write_hist_file/physics_history_simple.F90 index d39f1674..f73e5ac6 100644 --- a/test/unit/sample_files/write_hist_file/physics_history_simple.F90 +++ b/test/unit/sample_files/write_hist_file/physics_history_simple.F90 @@ -75,11 +75,11 @@ subroutine physics_history_out() integer :: const_index character(len=*), parameter :: subname = "physics_history_out" - call history_out_field('SLP', slp, size(slp, 1)) + call history_out_field('SLP', slp) call const_get_index('super_cool_cat_const', const_index, abort=.false., warning=.false.) if (const_index >= 0) then const_data_ptr => cam_constituents_array() - call history_out_field('COOL_CAT', const_data_ptr(:,:,const_index), size(const_data_ptr, 1)) + call history_out_field('COOL_CAT', const_data_ptr(:,:,const_index)) end if end subroutine physics_history_out diff --git a/test/unit/sample_files/write_init_files/ddt_array_reg.xml b/test/unit/sample_files/write_init_files/ddt_array_reg.xml index a523cf1b..969e6959 100644 --- a/test/unit/sample_files/write_init_files/ddt_array_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt_array_reg.xml @@ -12,7 +12,7 @@ units="Pa" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension slp sea_lev_pres - + @@ -30,7 +30,7 @@ index_name="index_of_potential_temperature" index_pos="number_of_thermo_vars"> theta pot_temp - + diff --git a/test/unit/test_build_cache.py b/test/unit/test_build_cache.py index 4e12a680..e0e2462c 100644 --- a/test/unit/test_build_cache.py +++ b/test/unit/test_build_cache.py @@ -423,7 +423,7 @@ def test_update_registry(self): #Set non-file update_registry inputs: ic_names = {"Only_had_a": ["heart", "brain"]} - diag_names = {"small_dog_wrt_dorothy": 'TOTO'} + diag_names = {"small_dog_wrt_dorothy": ('TOTO', 'avg')} dycore = "banana" #Update registry fields: diff --git a/test/unit/test_write_hist_file.py b/test/unit/test_write_hist_file.py index fbac4fb2..5ebd1799 100644 --- a/test/unit/test_write_hist_file.py +++ b/test/unit/test_write_hist_file.py @@ -189,7 +189,7 @@ def test_simple_reg_write_hist(self): self.assertTrue(os.path.exists(out_hist), msg=amsg) # For each output file, make sure it matches input file - amsg = f"{in_hist} does not match {out_hist}" + amsg = f"{out_hist} does not match {in_hist}" self.assertTrue(filecmp.cmp(in_hist, out_hist, shallow=False), msg=amsg) From 61963c8e81d838e2b3a9a1c5bf377b28560e2140 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 10 Jun 2024 20:53:38 -0600 Subject: [PATCH 27/79] remove fortran tests until we design a new framework --- test/hist_tests/CMakeLists.txt | 151 - test/hist_tests/cam_history_support.F90 | 9 - test/hist_tests/cam_interp_mod.F90 | 60 - test/hist_tests/run_test | 154 - test/hist_tests/sample_files/amwg_hist_config | 17 - test/hist_tests/sample_files/rrtmg_rad_config | 46 - .../sample_files/single_good_config.nl | 17 - .../sample_files/two_good_configs.nl | 28 - test/hist_tests/sample_files/user_nl_cam | 17 - .../sample_files/user_nl_cam_defaults | 17 - .../hist_tests/sample_files/user_nl_cam_rrtmg | 15 - test/hist_tests/test_history.F90 | 176 - test/include/cam_abortutils.F90 | 76 +- test/include/cam_control_mod.F90 | 50 - test/include/config.h | 0 test/include/dtypes.h | 6 - test/include/pio.F90 | 12 - test/include/shr_assert_mod.F90 | 8602 ----------------- test/include/shr_infnan_mod.F90 | 110 +- test/include/shr_kind_mod.F90 | 19 + test/include/shr_mem_mod.F90 | 63 - test/include/shr_string_mod.F90 | 1967 ---- test/include/spmd_utils.F90 | 5 +- test/include/time_manager.F90 | 312 - test/utils_tests/CMakeLists.txt | 127 - test/utils_tests/string_utils_tests.F90 | 88 - test/utils_tests/test_utils.F90 | 30 - 27 files changed, 133 insertions(+), 12041 deletions(-) delete mode 100644 test/hist_tests/CMakeLists.txt delete mode 100644 test/hist_tests/cam_history_support.F90 delete mode 100644 test/hist_tests/cam_interp_mod.F90 delete mode 100755 test/hist_tests/run_test delete mode 100644 test/hist_tests/sample_files/amwg_hist_config delete mode 100644 test/hist_tests/sample_files/rrtmg_rad_config delete mode 100644 test/hist_tests/sample_files/single_good_config.nl delete mode 100644 test/hist_tests/sample_files/two_good_configs.nl delete mode 100644 test/hist_tests/sample_files/user_nl_cam delete mode 100644 test/hist_tests/sample_files/user_nl_cam_defaults delete mode 100644 test/hist_tests/sample_files/user_nl_cam_rrtmg delete mode 100644 test/hist_tests/test_history.F90 delete mode 100644 test/include/cam_control_mod.F90 delete mode 100644 test/include/config.h delete mode 100644 test/include/dtypes.h delete mode 100644 test/include/pio.F90 delete mode 100644 test/include/shr_assert_mod.F90 create mode 100644 test/include/shr_kind_mod.F90 delete mode 100644 test/include/shr_mem_mod.F90 delete mode 100644 test/include/shr_string_mod.F90 delete mode 100644 test/include/time_manager.F90 delete mode 100644 test/utils_tests/CMakeLists.txt delete mode 100644 test/utils_tests/string_utils_tests.F90 delete mode 100644 test/utils_tests/test_utils.F90 diff --git a/test/hist_tests/CMakeLists.txt b/test/hist_tests/CMakeLists.txt deleted file mode 100644 index e1c84e53..00000000 --- a/test/hist_tests/CMakeLists.txt +++ /dev/null @@ -1,151 +0,0 @@ -CMAKE_MINIMUM_REQUIRED(VERSION 3.11) -PROJECT(TestHistConfig) -ENABLE_LANGUAGE(Fortran) - -include(CMakeForceCompiler) - -find_package(MPI REQUIRED) -add_definitions(${MPI_Fortran_COMPILE_FLAGS}) -include_directories(${MPI_Fortran_INCLUDE_PATH}) -link_directories(${MPI_Fortran_LIBRARIES}) - -# Command line switches -SET(ABORT "OFF" CACHE BOOL "If ON, endrun aborts job") -#----------------------------------------------------------------------------- -# -# Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) -# -#----------------------------------------------------------------------------- -GET_FILENAME_COMPONENT(TEST_PATH ${CMAKE_CURRENT_SOURCE_DIR} DIRECTORY) -SET(UTILS_PATH ${TEST_PATH}/include) -GET_FILENAME_COMPONENT(ROOT_PATH ${TEST_PATH} DIRECTORY) -SET(SRC_PATH ${ROOT_PATH}/src) -SET(HIST_PATH ${SRC_PATH}/history) -# Find CIME directory -if (EXISTS "${ROOT_PATH}/cime") - SET(CIME_PATH ${ROOT_PATH}/cime) -else(EXISTS "${ROOT_PATH}/cime") - GET_FILENAME_COMPONENT(_components ${ROOT_PATH} DIRECTORY) - GET_FILENAME_COMPONENT(_toplev ${_components} DIRECTORY) - SET(CIME_PATH ${_toplev}/cime) -endif(EXISTS "${ROOT_PATH}/cime") -# Test copies of CAM and CIME utility files -if (NOT ${ABORT}) - LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_abortutils.F90") -endif(NOT ${ABORT}) -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_logfile.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/ccpp_kinds.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/spmd_utils.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_infnan_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_assert_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_string_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/time_manager.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/cam_control_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/pio.F90") -LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_interp_mod.F90") -LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/cam_history_support.F90") -# Regular CAM and CIME utility files -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_kind_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_mpi_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_abort_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_sys_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_timer_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_log_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_nl_mod.F90") -LIST(APPEND SOURCE_FILES "${ROOT_PATH}/share/src/shr_strconvert_mod.F90") -LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") -LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_filenames.F90") -if (${ABORT}) - LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/cam_abortutils.F90") - LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_mem_mod.F90") -endif(${ABORT}) -# CAM history files -LIST(APPEND SOURCE_FILES "${HIST_PATH}/cam_hist_file.F90") -## We need to copy shr_assert.h into this directory -#configure_file("${CIME_PATH}/src/share/util/shr_assert.h" -# "${CMAKE_CURRENT_SOURCE_DIR}/shr_assert.h" COPYONLY) -# TEST_EXE.F90 is the name of the program source file -SET(TEST_EXE "test_history") -ADD_EXECUTABLE(${TEST_EXE} ${TEST_EXE}.F90) - -#----------------------------------------------------------------------------- -############################################################################## -# -# End of project-specific input -# -############################################################################## -#----------------------------------------------------------------------------- - -# Use rpaths on MacOSX -set(CMAKE_MACOSX_RPATH 1) - -#----------------------------------------------------------------------------- -# Set a default build type if none was specified -if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) - #message(STATUS "Setting build type to 'Debug' as none was specified.") - #set(CMAKE_BUILD_TYPE Debug CACHE STRING "Choose the type of build." FORCE) - message(STATUS "Setting build type to 'Release' as none was specified.") - set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) - - # Set the possible values of build type for cmake-gui - set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" - "MinSizeRel" "RelWithDebInfo") -endif() - -ADD_COMPILE_OPTIONS(-O0) - -if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") -# gfortran -# MESSAGE("gfortran being used.") - ADD_COMPILE_OPTIONS(-fcheck=all) - ADD_COMPILE_OPTIONS(-fbacktrace) - ADD_COMPILE_OPTIONS(-ffpe-trap=zero) - ADD_COMPILE_OPTIONS(-finit-real=nan) - ADD_COMPILE_OPTIONS(-ggdb) - ADD_COMPILE_OPTIONS(-ffree-line-length-none) - ADD_COMPILE_OPTIONS(-cpp) - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DHAVE_IEEE_ARITHMETIC") -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") -# ifort -# MESSAGE("ifort being used.") - #ADD_COMPILE_OPTIONS(-check all) - ADD_COMPILE_OPTIONS(-fpe0) - ADD_COMPILE_OPTIONS(-warn) - ADD_COMPILE_OPTIONS(-traceback) - ADD_COMPILE_OPTIONS(-debug extended) - ADD_COMPILE_OPTIONS(-fpp) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") -# pgf90 -# MESSAGE("pgf90 being used.") - ADD_COMPILE_OPTIONS(-g) - ADD_COMPILE_OPTIONS(-Mipa=noconst) - ADD_COMPILE_OPTIONS(-traceback) - ADD_COMPILE_OPTIONS(-Mfree) - ADD_COMPILE_OPTIONS(-Mfptrap) - ADD_COMPILE_OPTIONS(-Mpreprocess) -else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - message (FATAL_ERROR "This program has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${CMAKE_SOURCE_DIR}/CMakeLists.txt") -endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") -set (CMAKE_Fortran_FLAGS - "${CMAKE_Fortran_FLAGS} -I${ROOT_PATH}/share/include") - -#----------------------------------------------------------------------------- -# Set OpenMP flags for C/C++/Fortran -if (OPENMP) - include(detect_openmp) - detect_openmp() - set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ${OpenMP_C_FLAGS}") - set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${OpenMP_CXX_FLAGS}") - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") - message(STATUS "Enable OpenMP support for C/C++/Fortran compiler") -else(OPENMP) - message (STATUS "Disable OpenMP support for C/C++/Fortran compiler") -endif() -TARGET_SOURCES(${TEST_EXE} PUBLIC ${SOURCE_FILES}) -# Allow include files in ../include -TARGET_INCLUDE_DIRECTORIES(${TEST_EXE} PRIVATE ${UTILS_PATH}) -TARGET_LINK_LIBRARIES(${TEST_EXE} ${MPI_Fortran_LIBRARIES}) - -set_target_properties(${TEST_EXE} PROPERTIES - COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" - LINK_FLAGS "${CMAKE_Fortran_FLAGS}") diff --git a/test/hist_tests/cam_history_support.F90 b/test/hist_tests/cam_history_support.F90 deleted file mode 100644 index 3a527ee6..00000000 --- a/test/hist_tests/cam_history_support.F90 +++ /dev/null @@ -1,9 +0,0 @@ -module cam_history_support - - implicit none - private - save - - integer, public :: max_fieldname_len = 63 - -end module cam_history_support diff --git a/test/hist_tests/cam_interp_mod.F90 b/test/hist_tests/cam_interp_mod.F90 deleted file mode 100644 index 0b9e6a5c..00000000 --- a/test/hist_tests/cam_interp_mod.F90 +++ /dev/null @@ -1,60 +0,0 @@ -module cam_interp_mod - - use shr_kind_mod, only: r8=>shr_kind_r8 - - implicit none - private - - ! Some parameters for use with interpolated output namelist items - integer, parameter, public :: interp_type_native = 0 - integer, parameter, public :: interp_type_bilinear = 1 - integer, parameter, public :: interp_gridtype_equal_poles = 1 - integer, parameter, public :: interp_gridtype_gauss = 2 - integer, parameter, public :: interp_gridtype_equal_nopoles = 3 - - type, public :: hist_interp_info_t - ! store the lat-lon grid information - character(len=28) :: gridname = '' - integer :: grid_id = -1 - ! gridtype = 1 equally spaced, including poles (FV scalars output grid) - ! gridtype = 2 Gauss grid (CAM Eulerian) - ! gridtype = 3 equally spaced, no poles (FV staggered velocity) - integer :: interp_gridtype = interp_gridtype_equal_poles - ! interpolate_type = 0: native high order interpolation - ! interpolate_type = 1: bilinear interpolation - integer :: interp_type = interp_type_bilinear - integer :: interp_nlat = 0 - integer :: interp_nlon = 0 - real(r8), pointer :: interp_lat(:) => NULL() - real(r8), pointer :: interp_lon(:) => NULL() - real(r8), pointer :: interp_gweight(:) => NULL() - contains - procedure :: reset => interp_reset - end type hist_interp_info_t - -CONTAINS - - subroutine interp_reset(this) - class(hist_interp_info_t), intent(inout) :: this - - this%gridname = '' - this%grid_id = -1 - this%interp_gridtype = interp_gridtype_equal_poles - this%interp_type = interp_type_bilinear - this%interp_nlat = 0 - this%interp_nlon = 0 - if (associated(this%interp_lat)) then - deallocate(this%interp_lat) - nullify(this%interp_lat) - end if - if (associated(this%interp_lon)) then - deallocate(this%interp_lon) - nullify(this%interp_lon) - end if - if (associated(this%interp_gweight)) then - deallocate(this%interp_gweight) - nullify(this%interp_gweight) - end if - end subroutine interp_reset - -end module cam_interp_mod diff --git a/test/hist_tests/run_test b/test/hist_tests/run_test deleted file mode 100755 index 3ee880b2..00000000 --- a/test/hist_tests/run_test +++ /dev/null @@ -1,154 +0,0 @@ -#! /bin/bash - -currdir="`pwd -P`" -scriptdir="$( cd $( dirname $0 ); pwd -P )" - -## -## Option default values -## -defdir="build" -build_dir="${currdir}/${defdir}" -cleanup="PASS" # Other supported options are ALWAYS and NEVER -abort="OFF" # Use "ON" to use real endrun call -verbosity=0 - -## -## General syntax help function -## Usage: help -## -help () { - local hname="Usage: `basename ${0}`" - local hprefix="`echo ${hname} | tr '[!-~]' ' '`" - echo "${hname} [ --build-dir ] [ --cleanup ] [ --abort ]" - hprefix=" " - echo "" - echo "${hprefix} : Directory for building and running the test" - echo "${hprefix} default is /${defdir}" - echo "${hprefix} : Cleanup option is ALWAYS, NEVER, or PASS" - echo "${hprefix} default is PASS" - echo "${hprefix} --abort will cause endrun calls to stop test (debug only)" - exit $1 -} - -## -## Error output function (should be handed a string) -## -perr() { - >&2 echo -e "\nERROR: ${@}\n" - exit 1 -} - -## -## Cleanup the build and test directory -## -docleanup() { - # We start off in the build directory - if [ "${build_dir}" == "${currdir}" ]; then - echo "WARNING: Cannot clean ${build_dir}" - else - cd ${currdir} - rm -rf ${build_dir} - fi -} - -## Process our input arguments -while [ $# -gt 0 ]; do - case $1 in - --h | -h | --help | -help) - help 0 - ;; - --abort) - abort="ON" - ;; - --build-dir) - if [ $# -lt 2 ]; then - perr "${1} requires a build directory" - fi - build_dir="${2}" - shift - ;; - --cleanup) - if [ $# -lt 2 ]; then - perr "${1} requies a cleanup option (ALWAYS, NEVER, PASS)" - fi - if [ "${2}" == "ALWAYS" -o "${2}" == "NEVER" -o "${2}" == "PASS" ]; then - cleanup="${2}" - else - perr "Allowed cleanup options: ALWAYS, NEVER, PASS" - fi - shift - ;; - *) - perr "Unrecognized option, \"${1}\"" - ;; - esac - shift -done - -# Create the build directory, if necessary -if [ -d "${build_dir}" ]; then - # Always make sure build_dir is not in the test dir - if [ "$( cd ${build_dir}; pwd -P )" == "${currdir}" ]; then - build_dir="${build_dir}/${defdir}" - fi -else - mkdir -p ${build_dir} - res=$? - if [ $res -ne 0 ]; then - perr "Unable to create build directory, '${build_dir}'" - fi -fi -build_dir="$( cd ${build_dir}; pwd -P )" -sampledir="${scriptdir}/sample_files" -if [ ! -d "${sampledir}" ]; then - perr "No samples files directory found at '${sampledir}'" -fi - -# cd to the build directory -cd ${build_dir} -res=$? -if [ $res -ne 0 ]; then - perr "Unable to cd to build directory, '${build_dir}'" -fi -# Clean build directory -rm -rf * -res=$? -if [ $res -ne 0 ]; then - perr "Unable to clean build directory, '${build_dir}'" -fi -# Run CMake -opts="" -if [ "${abort}" == "ON" ]; then - opts="${opts} -DABORT=ON" -fi -cmake ${scriptdir} ${opts} -res=$? -if [ $res -ne 0 ]; then - perr "CMake failed with exit code, ${res}" -fi -# Run make -make -res=$? -if [ $res -ne 0 ]; then - perr "make failed with exit code, ${res}" -fi -# Run test with 1 task -mpirun -n 1 ./test_history ${sampledir} -res=$? -if [ $res -ne 0 ]; then - perr "test_history with one task failed with exit code, ${res}" -fi -# Run test with 4 tasks -mpirun -n 4 ./test_history ${sampledir} -res=$? -if [ $res -ne 0 ]; then - perr "test_history with four tasks failed with exit code, ${res}" -fi - -if [ "${cleanup}" == "ALWAYS" ]; then - docleanup -elif [ $res -eq 0 -a "${cleanup}" == "PASS" ]; then - docleanup -fi - -exit $res diff --git a/test/hist_tests/sample_files/amwg_hist_config b/test/hist_tests/sample_files/amwg_hist_config deleted file mode 100644 index 799ab339..00000000 --- a/test/hist_tests/sample_files/amwg_hist_config +++ /dev/null @@ -1,17 +0,0 @@ -max_frames: 1 -output_frequency: monthly -precision: REAL32 -output_levels: IPCC_PRESSURE_LEVELS - -! ADF mean -diag_file: adf_mean_config -! Radiation -!diag_file: rad_config -! Gravity wave -diag_file: grav_wav_config -! Turbulent mountain stress -add_avg_fields: TAUTMSX, TAUTMSY -! Modal aerosol optics -add_avg_fields: AODDUST1, AODDUST3, AODDUST, AODVIS -! ndrop -add_avg_fields: CCN3 diff --git a/test/hist_tests/sample_files/rrtmg_rad_config b/test/hist_tests/sample_files/rrtmg_rad_config deleted file mode 100644 index ff5971c2..00000000 --- a/test/hist_tests/sample_files/rrtmg_rad_config +++ /dev/null @@ -1,46 +0,0 @@ -add_avg_fields;h0: SOLIN, SOLIN_d1, SOLIN_d2, SOLIN_d3, SOLIN_d4, SOLIN_d5 -add_avg_fields;h4: SOLIN_d6, SOLIN_d7, SOLIN_d8, SOLIN_d9, SOLIN_d10 -add_avg_fields: QRS, QRS_d1, QRS_d2, QRS_d3, QRS_d4, QRS_d5 -add_avg_fields: QRS_d6, QRS_d7, QRS_d8, QRS_d9, QRS_d10 -add_avg_fields: FSNT, FSNT_d1, FSNT_d2, FSNT_d3, FSNT_d4, FSNT_d5 -add_avg_fields: FSNT_d6, FSNT_d7, FSNT_d8, FSNT_d9, FSNT_d10 -add_avg_fields: FSNTC, FSNTC_d1, FSNTC_d2, FSNTC_d3, FSNTC_d4, FSNTC_d5 -add_avg_fields: FSNTC_d6, FSNTC_d7, FSNTC_d8, FSNTC_d9, FSNTC_d10 -add_avg_fields: FSNTOA, FSNTOA_d1, FSNTOA_d2, FSNTOA_d3, FSNTOA_d4, FSNTOA_d5 -add_avg_fields: FSNTOA_d6, FSNTOA_d7, FSNTOA_d8, FSNTOA_d9, FSNTOA_d10 -add_avg_fields: FSNTOAC, FSNTOAC_d1, FSNTOAC_d2, FSNTOAC_d3, FSNTOAC_d4, FSNTOAC_d5 -add_avg_fields: FSNTOAC_d6, FSNTOAC_d7, FSNTOAC_d8, FSNTOAC_d9, FSNTOAC_d10 -add_avg_fields: SWCF, SWCF_d1, SWCF_d2, SWCF_d3, SWCF_d4, SWCF_d5 -add_avg_fields: SWCF_d6, SWCF_d7, SWCF_d8, SWCF_d9, SWCF_d10 -add_avg_fields: FSNS, FSNS_d1, FSNS_d2, FSNS_d3, FSNS_d4, FSNS_d5 -add_avg_fields: FSNS_d6, FSNS_d7, FSNS_d8, FSNS_d9, FSNS_d10 -add_avg_fields: FSNSC, FSNSC_d1, FSNSC_d2, FSNSC_d3, FSNSC_d4, FSNSC_d5 -add_avg_fields: FSNSC_d6, FSNSC_d7, FSNSC_d8, FSNSC_d9, FSNSC_d10 -add_avg_fields: FSUTOA, FSUTOA_d1, FSUTOA_d2, FSUTOA_d3, FSUTOA_d4, FSUTOA_d5 -add_avg_fields: FSUTOA_d6, FSUTOA_d7, FSUTOA_d8, FSUTOA_d9, FSUTOA_d10 -add_avg_fields: FSDSC, FSDSC_d1, FSDSC_d2, FSDSC_d3, FSDSC_d4, FSDSC_d5 -add_avg_fields: FSDSC_d6, FSDSC_d7, FSDSC_d8, FSDSC_d9, FSDSC_d10 -add_avg_fields: FSDS, FSDS_d1, FSDS_d2, FSDS_d3, FSDS_d4, FSDS_d5 -add_avg_fields: FSDS_d6, FSDS_d7, FSDS_d8, FSDS_d9, FSDS_d10 -add_avg_fields: QRL, QRL_d1, QRL_d2, QRL_d3, QRL_d4, QRL_d5 -add_avg_fields: QRL_d6, QRL_d7, QRL_d8, QRL_d9, QRL_d10 -add_avg_fields: FLNT, FLNT_d1, FLNT_d2, FLNT_d3, FLNT_d4, FLNT_d5 -add_avg_fields: FLNT_d6, FLNT_d7, FLNT_d8, FLNT_d9, FLNT_d10 -add_avg_fields: FLNTC, FLNTC_d1, FLNTC_d2, FLNTC_d3, FLNTC_d4, FLNTC_d5 -add_avg_fields: FLNTC_d6, FLNTC_d7, FLNTC_d8, FLNTC_d9, FLNTC_d10 -add_avg_fields: FLNTCLR, FLNTCLR_d1, FLNTCLR_d2, FLNTCLR_d3, FLNTCLR_d4, FLNTCLR_d5 -add_avg_fields: FLNTCLR_d6, FLNTCLR_d7, FLNTCLR_d8, FLNTCLR_d9, FLNTCLR_d10 -add_avg_fields: FREQCLR, FREQCLR_d1, FREQCLR_d2, FREQCLR_d3, FREQCLR_d4, FREQCLR_d5 -add_avg_fields: FREQCLR_d6, FREQCLR_d7, FREQCLR_d8, FREQCLR_d9, FREQCLR_d10 -add_avg_fields: FLUT, FLUT_d1, FLUT_d2, FLUT_d3, FLUT_d4, FLUT_d5 -add_avg_fields: FLUT_d6, FLUT_d7, FLUT_d8, FLUT_d9, FLUT_d10 -add_avg_fields: FLUTC, FLUTC_d1, FLUTC_d2, FLUTC_d3, FLUTC_d4, FLUTC_d5 -add_avg_fields: FLUTC_d6, FLUTC_d7, FLUTC_d8, FLUTC_d9, FLUTC_d10 -add_avg_fields: LWCF, LWCF_d1, LWCF_d2, LWCF_d3, LWCF_d4, LWCF_d5 -add_avg_fields: LWCF_d6, LWCF_d7, LWCF_d8, LWCF_d9, LWCF_d10 -add_avg_fields: FLNS, FLNS_d1, FLNS_d2, FLNS_d3, FLNS_d4, FLNS_d5 -add_avg_fields: FLNS_d6, FLNS_d7, FLNS_d8, FLNS_d9, FLNS_d10 -add_avg_fields: FLNSC, FLNSC_d1, FLNSC_d2, FLNSC_d3, FLNSC_d4, FLNSC_d5 -add_avg_fields: FLNSC_d6, FLNSC_d7, FLNSC_d8, FLNSC_d9, FLNSC_d10 -add_avg_fields: FLDS, FLDS_d1, FLDS_d2, FLDS_d3, FLDS_d4, FLDS_d5 -add_avg_fields: FLDS_d6, FLDS_d7, FLDS_d8, FLDS_d9, FLDS_d10 diff --git a/test/hist_tests/sample_files/single_good_config.nl b/test/hist_tests/sample_files/single_good_config.nl deleted file mode 100644 index cae541a8..00000000 --- a/test/hist_tests/sample_files/single_good_config.nl +++ /dev/null @@ -1,17 +0,0 @@ -! History file configuration with a single good entry -&hist_config_arrays_nl - hist_num_inst_fields = 3 - hist_num_avg_fields = 0 - hist_num_min_fields = 0 - hist_num_max_fields = 0 - hist_num_var_fields = 0 -/ - -&hist_file_config_nl - hist_volume = 'h1' - hist_inst_fields = 'A','B','C' - hist_precision = 'REAL32' - hist_max_frames = 13 - hist_output_frequency = '2*hours' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' -/ diff --git a/test/hist_tests/sample_files/two_good_configs.nl b/test/hist_tests/sample_files/two_good_configs.nl deleted file mode 100644 index baa92e71..00000000 --- a/test/hist_tests/sample_files/two_good_configs.nl +++ /dev/null @@ -1,28 +0,0 @@ -! History file configuration with two good entries -&hist_config_arrays_nl - hist_num_inst_fields = 3 - hist_num_avg_fields = 5 - hist_num_min_fields = 0 - hist_num_max_fields = 0 - hist_num_var_fields = 0 -/ - -&hist_file_config_nl - hist_volume = 'h1' - hist_inst_fields = 'A','B','C' - hist_precision = 'REAL32' - hist_max_frames = 13 - hist_output_frequency = '2*hours' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' -/ - -&hist_file_config_nl - hist_volume = 'h0' - hist_avg_fields = 'd','E', 'f', 'g' , "H" - hist_precision = 'REAL64' - hist_max_frames = 30 - hist_output_frequency = 'monthly' - hist_file_type = 'history' - hist_filename_spec = '%c.cam.%u.%y-%m-%d-%s.nc' -/ diff --git a/test/hist_tests/sample_files/user_nl_cam b/test/hist_tests/sample_files/user_nl_cam deleted file mode 100644 index d0026816..00000000 --- a/test/hist_tests/sample_files/user_nl_cam +++ /dev/null @@ -1,17 +0,0 @@ -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value - -ncdata = '/home/cesmdata/camden/kess_data.cam.h6.ne5.nc' -use_topo_file = .false. - -history_no_defaults: True -! History configuration -diag_file;h0: amwg_hist_config -remove_avg_fields;h0 TAUTMSX, TAUTMSY -output_levels;h0: IPCC_PRESSURE_LEVELS -add_pressure_levels;h0: 925hPa, 850, 500, 320 - - -output_levels;h3: MODEL_LEVELS -add_inst_fields;h3: T, U, V -output_frequency;h3: 2*nsteps diff --git a/test/hist_tests/sample_files/user_nl_cam_defaults b/test/hist_tests/sample_files/user_nl_cam_defaults deleted file mode 100644 index a468a543..00000000 --- a/test/hist_tests/sample_files/user_nl_cam_defaults +++ /dev/null @@ -1,17 +0,0 @@ -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value - -ncdata = 'atm/cam/inic/se/ape_topo_cam4_ne16np4_L32_c171020.nc' -use_topo_file = .false. - -history_no_defaults: False -! History configuration -diag_file;h0: amwg_hist_config -remove_avg_fields;h0 TAUTMSX, TAUTMSY -output_levels;h0: IPCC_PRESSURE_LEVELS -add_pressure_levels;h0: 925hPa, 850, 500, 320 - - -output_levels;h3: MODEL_LEVELS -add_inst_fields;h3: T, U, V -output_frequency;h3: 2*nsteps diff --git a/test/hist_tests/sample_files/user_nl_cam_rrtmg b/test/hist_tests/sample_files/user_nl_cam_rrtmg deleted file mode 100644 index 8adf7dde..00000000 --- a/test/hist_tests/sample_files/user_nl_cam_rrtmg +++ /dev/null @@ -1,15 +0,0 @@ -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value - -ncdata = '/home/cesmdata/camden/kess_data.cam.h6.ne5.nc' -use_topo_file = .false. - -! History configuration -diag_file;h0: rrtmg_rad_config -output_frequency;h0: monthly -precision;h0: REAL32 - -add_inst_fields;h3: T, U, V -output_frequency;h3: 2*nsteps -precision;h3: REAL64 -max_frames;h3: 24 diff --git a/test/hist_tests/test_history.F90 b/test/hist_tests/test_history.F90 deleted file mode 100644 index 82767c34..00000000 --- a/test/hist_tests/test_history.F90 +++ /dev/null @@ -1,176 +0,0 @@ -module test_hist_mod - - implicit none - private - - public :: run_test - -CONTAINS - - subroutine run_test(test_msg, test_file, sample_dir, out_unit, & - num_configs, volumes, max_frames, precisions, & - test_cnt, err_cnt) - use shr_kind_mod, only: max_flen=>SHR_KIND_CL - use cam_abortutils, only: endrun, check_endrun - use cam_hist_file, only: hist_file_t - use cam_hist_file, only: hist_read_namelist_config - - ! Dummy arguments - character(len=*), intent(in) :: test_msg - character(len=*), intent(in) :: test_file - character(len=*), intent(in) :: sample_dir - integer, intent(in) :: num_configs - character(len=*), intent(in) :: volumes(:) - integer, intent(in) :: max_frames(:) - character(len=*), intent(in) :: precisions(:) - integer, intent(in) :: out_unit - integer, intent(out) :: test_cnt - integer, intent(out) :: err_cnt - ! Local variables - type(hist_file_t), pointer :: tconfig_arr(:) - character(len=max_flen) :: test_path - integer :: indx - - test_cnt = 0 - err_cnt = 0 - test_cnt = test_cnt + 1 ! Did read work? - test_path = trim(sample_dir)//trim(test_file) - tconfig_arr => hist_read_namelist_config(test_path) - if (check_endrun(test_desc=test_msg, output=out_unit)) then - err_cnt = err_cnt + 1 - end if - if (err_cnt == 0) then - test_cnt = test_cnt + 1 ! Did the config array get allocated? - if (.not. associated(tconfig_arr)) then - err_cnt = err_cnt + 1 - write(out_unit, *) "FAIL: ", trim(test_msg), & - ": tconfig_arr not allocated" - end if - end if - if (err_cnt == 0) then - test_cnt = test_cnt + 1 ! Is the config array the right size? - if (size(tconfig_arr) /= num_configs) then - err_cnt = err_cnt + 1 - write(out_unit, '(3a,i0,a,i0)') "FAIL: ", trim(test_msg), & - ": tconfig_arr has ", size(tconfig_arr), & - " entries, should be ", num_configs - end if - do indx = 1, num_configs - test_cnt = test_cnt + 1 ! Is volume correct? - if (trim(tconfig_arr(indx)%filename()) /= trim(volumes(indx))) then - err_cnt = err_cnt + 1 - write(out_unit, '(3a,i0,5a)') "FAIL: ", trim(test_msg), & - ": volume(", indx, ") is '", & - trim(tconfig_arr(indx)%filename()), "', should be '", & - trim(volumes(indx)), "'" - end if - test_cnt = test_cnt + 1 ! Is max_frames correct? - if (tconfig_arr(indx)%max_frame() /= max_frames(indx)) then - err_cnt = err_cnt + 1 - write(out_unit, '(3a,i0,a,i0)') "FAIL: ", trim(test_msg), & - ": tconfig_arr has max_frames = ", & - tconfig_arr(indx)%max_frame(), ", should be ", & - max_frames(indx) - end if - test_cnt = test_cnt + 1 ! Is precision correct? - if (tconfig_arr(indx)%precision() /= precisions(indx)) then - err_cnt = err_cnt + 1 - write(out_unit, '(3a,i0,4a)') "FAIL: ", trim(test_msg), & - ": precision(", indx, ") is ", & - trim(tconfig_arr(indx)%precision()), ", should be ", & - trim(precisions(indx)) - end if - end do - end if - - end subroutine run_test - -end module test_hist_mod - -!========================================================================= - -program test_history - - use shr_kind_mod, only: max_chars=>SHR_KIND_CX - use shr_kind_mod, only: max_flen=>SHR_KIND_CL - use cam_abortutils, only: endrun, check_endrun - use cam_hist_file, only: hist_file_t - use cam_hist_file, only: hist_read_namelist_config - use test_hist_mod, only: run_test - - implicit none - - integer :: out_unit = 6 - integer :: ierr - integer :: errcnt - integer :: testcnt - integer :: total_errcnt = 0 - integer :: total_tests = 0 - character(len=max_flen) :: sample_dir - character(len=max_flen) :: test_file - character(len=max_chars) :: test_msg - type(hist_file_t), pointer :: test_config_arr(:) => NULL() - - ! Get sample directory from command line - errcnt = command_argument_count() - if (errcnt /= 1) then - call get_command_argument(0, value=test_file, status=ierr) - if (ierr > 0) then - test_file = "test_history.F90" - end if - write(6, *) "USAGE: ", trim(test_file), " " - STOP 1 - end if - call get_command_argument(1, value=sample_dir, status=ierr) - if (ierr > 0) then - write(6, *) "ERROR retrieving from command line" - STOP 1 - else if ((ierr < 0) .or. (len_trim(sample_dir) == max_flen)) then - write(6, *) "ERROR too long" - STOP 1 - end if - if (sample_dir(len_trim(sample_dir):len_trim(sample_dir)) /= "/") then - sample_dir = trim(sample_dir)//"/" - end if - - call MPI_init(errcnt) - - ! Read non-existent file test - test_file = trim(sample_dir)//"ThisFileBetterNotExist.fool" - test_config_arr => hist_read_namelist_config(test_file) - total_tests = total_tests + 1 - if (.not. check_endrun()) then - total_errcnt = total_errcnt + 1 - write(out_unit, *) "FAIL: Non-existent file read test" - end if - - ! Read single-good config test - test_file = "single_good_config.nl" - test_msg = "single_good_config.nl file read test" - call run_test(test_msg, test_file, sample_dir, out_unit, 1, & - (/ "%c.cam.h1.%y-%m-%d-%s.nc" /), (/ 13 /), & - (/ 'REAL32' /), testcnt, errcnt) - total_tests = total_tests + testcnt - total_errcnt = total_errcnt + errcnt - - ! Read single-good config test - test_file = "two_good_configs.nl" - test_msg = "two_good_configs.nl file read test" - call run_test(test_msg, test_file, sample_dir, out_unit, 2, & - (/ "%c.cam.h1.%y-%m-%d-%s.nc", "%c.cam.h0.%y-%m-%d-%s.nc" /), & - (/ 13, 30 /), (/ 'REAL32', 'REAL64' /), testcnt, errcnt) - total_tests = total_tests + testcnt - total_errcnt = total_errcnt + errcnt - - call MPI_finalize(errcnt) - - if (total_errcnt > 0) then - write(6, '(2(a,i0))') 'FAIL, error count = ', total_errcnt, & - ' / ', total_tests - STOP 1 - else - write(6, '(a,i0,a)') "All ", total_tests, " history tests passed!" - STOP 0 - end if - -end program test_history diff --git a/test/include/cam_abortutils.F90 b/test/include/cam_abortutils.F90 index 59bdfe37..8db9729e 100644 --- a/test/include/cam_abortutils.F90 +++ b/test/include/cam_abortutils.F90 @@ -1,79 +1,17 @@ module cam_abortutils - use shr_kind_mod, only: max_chars=>SHR_KIND_CX + implicit none + private - implicit none - private - - public :: endrun - public :: check_endrun - public :: check_allocate - - character(len=max_chars) :: abort_msg = '' + public endrun CONTAINS - logical function check_endrun(test_desc, output) - character(len=*), optional, intent(in) :: test_desc - integer, optional, intent(in) :: output - - ! Return .true. if an endrun message has been created - check_endrun = len_trim(abort_msg) > 0 - if (check_endrun .and. present(output)) then - ! Output the endrun message to - if (output > 0) then - if (present(test_desc)) then - write(output, *) "FAIL: ", trim(test_desc) - end if - write(output, *) trim(abort_msg) - end if - end if - ! Always clear the endrun message - abort_msg = '' - end function check_endrun - - subroutine endrun(message, file, line) - ! Dummy arguments - character(len=*), intent(in) :: message - character(len=*), optional, intent(in) :: file - integer, optional, intent(in) :: line - - if (present(file) .and. present(line)) then - write(abort_msg, '(4a,i0)') trim(message), ' at ', trim(file), ':', line - else if (present(file)) then - write(abort_msg, '(3a)') trim(message), ' at ', trim(file) - else if (present(line)) then - write(abort_msg, '(2a,i0)') trim(message), ' on line ', line - else - write(abort_msg, '(a)') trim(message) - end if + subroutine endrun(msg) + character(len=*), intent(in) :: msg + write(6, *) msg + STOP end subroutine endrun - subroutine check_allocate(errcode, subname, fieldname, errmsg, file, line) - ! If is not zero, call endrun with an error message - - ! Dummy arguments - integer, intent(in) :: errcode - character(len=*), intent(in) :: subname - character(len=*), intent(in) :: fieldname - character(len=*), optional, intent(in) :: errmsg - character(len=*), optional, intent(in) :: file - integer, optional, intent(in) :: line - ! Local variable - character(len=max_chars) :: abort_msg - - if (errcode /= 0) then - if (present(errmsg)) then - write(abort_msg, '(6a)') trim(subname), ": Allocate of '", & - trim(fieldname), "' failed; '", trim(errmsg), "'" - else - write(abort_msg, '(4a,i0)') trim(subname), ": Allocate of '", & - trim(fieldname), "' failed with code ", errcode - end if - call endrun(abort_msg, file=file, line=line) - end if - - end subroutine check_allocate - end module cam_abortutils diff --git a/test/include/cam_control_mod.F90 b/test/include/cam_control_mod.F90 deleted file mode 100644 index ceae6c0e..00000000 --- a/test/include/cam_control_mod.F90 +++ /dev/null @@ -1,50 +0,0 @@ -module cam_control_mod -!------------------------------------------------------------------------------ -! -! High level control variables. Information received from the driver/coupler is -! stored here. -! -!------------------------------------------------------------------------------ - - use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs, cl=>shr_kind_cl - use spmd_utils, only: masterproc - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - implicit none - public - save - - ! Public Routines: - ! - ! cam_ctrl_init - ! cam_ctrl_set_orbit - ! cam_ctrl_set_physics_type - - character(len=cl), protected :: caseid = '' ! case ID - character(len=cl), protected :: ctitle = '' ! case title - - logical, protected :: initial_run ! startup mode which only requires a minimal initial file - logical, protected :: restart_run ! continue a previous run; requires a restart file - logical, protected :: branch_run ! branch from a previous run; requires a restart file - - logical, protected :: adiabatic ! true => no physics - logical, protected :: ideal_phys ! true => run Held-Suarez (1994) physics - logical, protected :: kessler_phys ! true => run Kessler physics - logical, protected :: tj2016_phys ! true => run tj2016 physics - logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys - ! or tj2016 - logical, protected :: aqua_planet ! Flag to run model in "aqua planet" mode - logical, protected :: moist_physics ! true => moist physics enabled, i.e., - ! (.not. ideal_phys) .and. (.not. adiabatic) - - logical, protected :: brnch_retain_casename ! true => branch run may use same caseid as - ! the run being branched from - - real(r8), protected :: eccen ! Earth's eccentricity factor (unitless) (typically 0 to 0.1) - real(r8), protected :: obliqr ! Earth's obliquity in radians - real(r8), protected :: lambm0 ! Mean longitude of perihelion at the - ! vernal equinox (radians) - real(r8), protected :: mvelpp ! Earth's moving vernal equinox longitude - ! of perihelion plus pi (radians) -end module cam_control_mod diff --git a/test/include/config.h b/test/include/config.h deleted file mode 100644 index e69de29b..00000000 diff --git a/test/include/dtypes.h b/test/include/dtypes.h deleted file mode 100644 index f2e5b000..00000000 --- a/test/include/dtypes.h +++ /dev/null @@ -1,6 +0,0 @@ -#define TYPETEXT 100 -#define TYPEREAL 101 -#define TYPEDOUBLE 102 -#define TYPEINT 103 -#define TYPELONG 104 -#define TYPELOGICAL 105 diff --git a/test/include/pio.F90 b/test/include/pio.F90 deleted file mode 100644 index e60a995c..00000000 --- a/test/include/pio.F90 +++ /dev/null @@ -1,12 +0,0 @@ -module pio - - !! Fake PIO types and interfaces for testing - - implicit none - private - - type, public :: file_desc_t - character(len=32) :: name = "Fake PIO file descriptor" - end type file_desc_t - -end module pio diff --git a/test/include/shr_assert_mod.F90 b/test/include/shr_assert_mod.F90 deleted file mode 100644 index 1def7c73..00000000 --- a/test/include/shr_assert_mod.F90 +++ /dev/null @@ -1,8602 +0,0 @@ -#include "dtypes.h" -!=================================================== -! DO NOT EDIT THIS FILE, it was generated using /home/user/Projects/CAMDEN/cime/src/externals/genf90/genf90.pl -! Any changes you make to this file may be lost -!=================================================== -module shr_assert_mod - -! Assert subroutines for common debugging operations. - -use shr_kind_mod, only: & - r4 => shr_kind_r4, & - r8 => shr_kind_r8, & - i4 => shr_kind_i4, & - i8 => shr_kind_i8 - -use shr_sys_mod, only: & - shr_sys_abort - -use shr_log_mod, only: & - shr_log_Unit - -use shr_infnan_mod, only: shr_infnan_isnan - -use shr_strconvert_mod, only: toString - -implicit none -private -save - -! Assert that a logical is true. -public :: shr_assert -public :: shr_assert_all -public :: shr_assert_any - -! Assert that a numerical value satisfies certain constraints. -public :: shr_assert_in_domain - -# 33 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface shr_assert_all - module procedure shr_assert - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_1d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_2d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_3d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_4d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_5d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_6d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_all_7d -end interface - -# 39 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface shr_assert_any - module procedure shr_assert - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_1d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_2d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_3d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_4d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_5d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_6d - ! DIMS 1,2,3,4,5,6,7 - module procedure shr_assert_any_7d -end interface - -# 45 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface shr_assert_in_domain - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_0d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_1d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_2d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_3d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_4d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_5d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_6d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_7d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_0d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_1d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_2d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_3d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_4d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_5d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_6d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_7d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_0d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_1d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_2d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_3d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_4d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_5d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_6d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_7d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_0d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_1d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_2d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_3d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_4d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_5d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_6d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure shr_assert_in_domain_7d_long -end interface - -! Private utilities. - -# 53 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface print_bad_loc - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_0d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_1d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_2d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_3d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_4d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_5d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_6d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_7d_double - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_0d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_1d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_2d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_3d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_4d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_5d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_6d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_7d_real - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_0d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_1d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_2d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_3d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_4d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_5d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_6d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_7d_int - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_0d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_1d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_2d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_3d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_4d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_5d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_6d_long - ! TYPE double,real,int,long - ! DIMS 0,1,2,3,4,5,6,7 - module procedure print_bad_loc_7d_long -end interface - -# 59 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface find_first_loc - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_0d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_1d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_2d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_3d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_4d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_5d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_6d - ! DIMS 0,1,2,3,4,5,6,7 - module procedure find_first_loc_7d -end interface - -# 64 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -interface within_tolerance - ! TYPE double,real,int,long - module procedure within_tolerance_double - ! TYPE double,real,int,long - module procedure within_tolerance_real - ! TYPE double,real,int,long - module procedure within_tolerance_int - ! TYPE double,real,int,long - module procedure within_tolerance_long -end interface - -# 69 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -contains - -# 71 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - character(len=:), allocatable :: full_msg - - if (.not. var) then - full_msg = 'ERROR' - if (present(file)) then - full_msg = full_msg // ' in ' // trim(file) - if (present(line)) then - full_msg = full_msg // ' at line ' // toString(line) - end if - end if - if (present(msg)) then - full_msg = full_msg // ': ' // msg - end if - call shr_sys_abort(full_msg) - end if - -# 98 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert - -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_1d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_1d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_2d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_2d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_3d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_3d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_4d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_4d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_5d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_5d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_6d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_6d -! DIMS 1,2,3,4,5,6,7 -# 101 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_all_7d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(all(var), msg=msg, file=file, line=line) - -# 114 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_all_7d - -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_1d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_1d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_2d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_2d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_3d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_3d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_4d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_4d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_5d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_5d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_6d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_6d -! DIMS 1,2,3,4,5,6,7 -# 117 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_any_7d(var, msg, file, line) - - ! Logical being asserted - logical, intent(in) :: var(:,:,:,:,:,:,:) - ! Optional error message if assert fails - character(len=*), intent(in), optional :: msg - ! Optional file and line of the caller, written out if given - ! (line is ignored if file is absent) - character(len=*), intent(in), optional :: file - integer , intent(in), optional :: line - - call shr_assert(any(var), msg=msg, file=file, line=line) - -# 130 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_any_7d - -!-------------------------------------------------------------------------- -!-------------------------------------------------------------------------- - -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_0d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (0 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(0) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,0) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_0d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_1d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (1 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(1) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,1) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_1d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_2d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (2 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(2) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,2) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_2d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_3d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (3 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(3) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,3) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_3d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_4d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (4 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(4) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,4) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_4d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_5d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (5 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(5) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,5) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_5d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_6d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (6 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(6) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,6) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_6d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_7d_double(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (102 == TYPEREAL) || (102 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (7 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r8), intent(in) :: var(:,:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r8), intent(in), optional :: lt - real(r8), intent(in), optional :: gt - real(r8), intent(in), optional :: le - real(r8), intent(in), optional :: ge - real(r8), intent(in), optional :: eq - real(r8), intent(in), optional :: ne - real(r8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(7) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,7) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_7d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_0d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (0 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(0) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,0) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_0d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_1d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (1 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(1) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,1) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_1d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_2d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (2 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(2) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,2) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_2d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_3d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (3 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(3) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,3) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_3d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_4d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (4 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(4) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,4) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_4d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_5d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (5 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(5) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,5) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_5d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_6d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (6 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(6) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,6) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_6d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_7d_real(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (101 == TYPEREAL) || (101 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (7 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - real(r4), intent(in) :: var(:,:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - real(r4), intent(in), optional :: lt - real(r4), intent(in), optional :: gt - real(r4), intent(in), optional :: le - real(r4), intent(in), optional :: ge - real(r4), intent(in), optional :: eq - real(r4), intent(in), optional :: ne - real(r4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(7) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - real(r4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,7) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_7d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_0d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (0 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(0) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,0) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_0d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_1d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (1 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(1) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,1) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_1d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_2d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (2 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(2) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,2) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_2d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_3d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (3 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(3) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,3) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_3d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_4d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (4 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(4) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,4) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_4d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_5d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (5 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(5) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,5) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_5d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_6d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (6 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(6) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,6) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_6d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_7d_int(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (103 == TYPEREAL) || (103 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (7 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i4), intent(in) :: var(:,:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i4), intent(in), optional :: lt - integer(i4), intent(in), optional :: gt - integer(i4), intent(in), optional :: le - integer(i4), intent(in), optional :: ge - integer(i4), intent(in), optional :: eq - integer(i4), intent(in), optional :: ne - integer(i4), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(7) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i4) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,7) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_7d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_0d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (0 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(0) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,0) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_0d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_1d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (1 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(1) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,1) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_1d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_2d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (2 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(2) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,2) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_2d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_3d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (3 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(3) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,3) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_3d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_4d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (4 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(4) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,4) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_4d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_5d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (5 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(5) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,5) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_5d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_6d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (6 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(6) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,6) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_6d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 137 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine shr_assert_in_domain_7d_long(var, varname, msg, & - is_nan, lt, gt, le, ge, eq, ne, abs_tol) - -!----------------------------- -! BEGIN defining local macros -!----------------------------- - -! Flag for floating point types. - -#if (104 == TYPEREAL) || (104 == TYPEDOUBLE) -#define TYPEFP -#else -#undef TYPEFP -#endif - -! "Generalized" macro functions allow transformational intrinsic functions -! to handle both scalars and arrays. - -#if (7 != 0) -! When given an array, use the intrinsics. -#define GEN_SIZE(x) size(x) -#define GEN_ALL(x) all(x) -#else - -! Scalar extensions: -! GEN_SIZE always returns 1 for a scalar. -! GEN_ALL (logical reduction) is a no-op for a scalar. -! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. -#define GEN_SIZE(x) 1 -#define GEN_ALL(x) x - -#endif - -!----------------------------- -! END macro section -!----------------------------- - - ! Variable being checked. - integer(i8), intent(in) :: var(:,:,:,:,:,:,:) - ! Variable name to be used in error messages. - character(len=*), intent(in), optional :: varname - ! Optional error message if assert fails. - character(len=*), intent(in), optional :: msg - ! Assert that the variable is not (or is) NaN. - logical, intent(in), optional :: is_nan - ! Limits for (in)equalities. - integer(i8), intent(in), optional :: lt - integer(i8), intent(in), optional :: gt - integer(i8), intent(in), optional :: le - integer(i8), intent(in), optional :: ge - integer(i8), intent(in), optional :: eq - integer(i8), intent(in), optional :: ne - integer(i8), intent(in), optional :: abs_tol - - ! Note that the following array is size 0 for scalars. - integer :: loc_vec(7) - - logical :: is_nan_passed - logical :: lt_passed - logical :: gt_passed - logical :: le_passed - logical :: ge_passed - logical :: eq_passed - logical :: ne_passed - - integer(i8) :: abs_tol_loc - - ! Handling of abs_tol makes a couple of fairly safe assumptions. - ! 1. It is not the most negative integer. - ! 2. It is finite (not a floating point infinity or NaN). - if (present(abs_tol)) then - abs_tol_loc = abs(abs_tol) - else - abs_tol_loc = 0_i4 - end if - - is_nan_passed = .true. - lt_passed = .true. - gt_passed = .true. - le_passed = .true. - ge_passed = .true. - eq_passed = .true. - ne_passed = .true. - - ! Do one pass just to find out if we can return with no problem. - -#ifdef TYPEFP - ! Only floating-point values can actually be Inf/NaN. - if (present(is_nan)) & - is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) -#else - if (present(is_nan)) & - is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 -#endif - - if (present(lt)) & - lt_passed = GEN_ALL(var < lt) - - if (present(gt)) & - gt_passed = GEN_ALL(var > gt) - - if (present(le)) & - le_passed = GEN_ALL(var <= le) - - if (present(ge)) & - ge_passed = GEN_ALL(var >= ge) - - if (present(eq)) then - eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) - end if - - if (present(ne)) then - ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) - end if - - if ( is_nan_passed .and. & - lt_passed .and. & - gt_passed .and. & - le_passed .and. & - ge_passed .and. & - eq_passed .and. & - ne_passed) & - return - - ! If we got here, assert will fail, so find out where so that we - ! can try to print something useful. - - if (.not. is_nan_passed) then -#ifdef TYPEFP - loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) "Expected value to be NaN." - else - write(shr_log_Unit,*) "Expected value to be a number." - end if -#else - loc_vec = spread(1,1,7) - call print_bad_loc(var, loc_vec, varname) - if (is_nan) then - write(shr_log_Unit,*) & - "Asserted NaN, but the variable is not floating-point!" - end if -#endif - end if - - if (.not. lt_passed) then - loc_vec = find_first_loc(var >= lt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than ",lt - end if - - if (.not. gt_passed) then - loc_vec = find_first_loc(var <= gt) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than ",gt - end if - - if (.not. le_passed) then - loc_vec = find_first_loc(var > le) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be less than or & - &equal to ",le - end if - - if (.not. ge_passed) then - loc_vec = find_first_loc(var < ge) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be greater than or & - &equal to ",ge - end if - - if (.not. eq_passed) then - loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to be equal to ",eq - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - if (.not. ne_passed) then - loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) - call print_bad_loc(var, loc_vec, varname) - write(shr_log_Unit,*) "Expected value to never be equal to ",ne - if (abs_tol_loc > 0) & - write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc - end if - - call shr_sys_abort(msg) - -! Undefine local macros. -#undef TYPEFP -#undef GEN_SIZE -#undef GEN_ALL - -# 332 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine shr_assert_in_domain_7d_long - -!-------------------------------------------------------------------------- -!-------------------------------------------------------------------------- - -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_0d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var - integer, intent(in) :: loc_vec(0) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (0 != 0) - var(), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_0d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_1d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:) - integer, intent(in) :: loc_vec(1) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (1 != 0) - var(loc_vec(1)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_1d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_2d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:) - integer, intent(in) :: loc_vec(2) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (2 != 0) - var(loc_vec(1),& -loc_vec(2)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_2d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_3d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:,:) - integer, intent(in) :: loc_vec(3) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (3 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_3d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_4d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:,:,:) - integer, intent(in) :: loc_vec(4) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (4 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_4d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_5d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:,:,:,:) - integer, intent(in) :: loc_vec(5) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (5 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_5d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_6d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:,:,:,:,:) - integer, intent(in) :: loc_vec(6) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (6 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_6d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_7d_double(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r8), intent(in) :: var(:,:,:,:,:,:,:) - integer, intent(in) :: loc_vec(7) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (7 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6),& -loc_vec(7)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_7d_double -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_0d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var - integer, intent(in) :: loc_vec(0) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (0 != 0) - var(), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_0d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_1d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:) - integer, intent(in) :: loc_vec(1) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (1 != 0) - var(loc_vec(1)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_1d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_2d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:) - integer, intent(in) :: loc_vec(2) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (2 != 0) - var(loc_vec(1),& -loc_vec(2)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_2d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_3d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:,:) - integer, intent(in) :: loc_vec(3) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (3 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_3d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_4d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:,:,:) - integer, intent(in) :: loc_vec(4) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (4 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_4d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_5d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:,:,:,:) - integer, intent(in) :: loc_vec(5) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (5 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_5d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_6d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:,:,:,:,:) - integer, intent(in) :: loc_vec(6) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (6 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_6d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_7d_real(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - real(r4), intent(in) :: var(:,:,:,:,:,:,:) - integer, intent(in) :: loc_vec(7) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (7 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6),& -loc_vec(7)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_7d_real -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_0d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var - integer, intent(in) :: loc_vec(0) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (0 != 0) - var(), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_0d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_1d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:) - integer, intent(in) :: loc_vec(1) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (1 != 0) - var(loc_vec(1)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_1d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_2d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:) - integer, intent(in) :: loc_vec(2) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (2 != 0) - var(loc_vec(1),& -loc_vec(2)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_2d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_3d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:,:) - integer, intent(in) :: loc_vec(3) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (3 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_3d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_4d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:,:,:) - integer, intent(in) :: loc_vec(4) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (4 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_4d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_5d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:,:,:,:) - integer, intent(in) :: loc_vec(5) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (5 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_5d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_6d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:,:,:,:,:) - integer, intent(in) :: loc_vec(6) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (6 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_6d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_7d_int(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i4), intent(in) :: var(:,:,:,:,:,:,:) - integer, intent(in) :: loc_vec(7) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (7 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6),& -loc_vec(7)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_7d_int -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_0d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var - integer, intent(in) :: loc_vec(0) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (0 != 0) - var(), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_0d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_1d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:) - integer, intent(in) :: loc_vec(1) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (1 != 0) - var(loc_vec(1)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_1d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_2d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:) - integer, intent(in) :: loc_vec(2) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (2 != 0) - var(loc_vec(1),& -loc_vec(2)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_2d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_3d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:,:) - integer, intent(in) :: loc_vec(3) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (3 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_3d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_4d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:,:,:) - integer, intent(in) :: loc_vec(4) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (4 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_4d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_5d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:,:,:,:) - integer, intent(in) :: loc_vec(5) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (5 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_5d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_6d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:,:,:,:,:) - integer, intent(in) :: loc_vec(6) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (6 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_6d_long -! TYPE double,real,int,long -! DIMS 0,1,2,3,4,5,6,7 -# 339 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -subroutine print_bad_loc_7d_long(var, loc_vec, varname) - ! Print information about a bad location in an variable. - ! For scalars, just print value. - - integer(i8), intent(in) :: var(:,:,:,:,:,:,:) - integer, intent(in) :: loc_vec(7) - - character(len=*), intent(in), optional :: varname - - character(len=:), allocatable :: varname_to_write - - if (present(varname)) then - allocate(varname_to_write, source=varname) - else - allocate(varname_to_write, source="input variable") - end if - - write(shr_log_Unit,*) & - "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & - " has invalid value ", & -#if (7 != 0) - var(loc_vec(1),& -loc_vec(2),& -loc_vec(3),& -loc_vec(4),& -loc_vec(5),& -loc_vec(6),& -loc_vec(7)), & - " at location: ",loc_vec -#else - var - - ! Kill compiler spam for unused loc_vec. - if (.false.) write(*,*) loc_vec -#endif - -# 369 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end subroutine print_bad_loc_7d_long - -!-------------------------------------------------------------------------- -!-------------------------------------------------------------------------- - -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_0d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask - integer :: loc_vec(0) - -#if (0 != 0) - integer :: flags() - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_0d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_1d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:) - integer :: loc_vec(1) - -#if (1 != 0) - integer :: flags(size(mask,1)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_1d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_2d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:) - integer :: loc_vec(2) - -#if (2 != 0) - integer :: flags(size(mask,1),& -size(mask,2)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_2d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_3d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:,:) - integer :: loc_vec(3) - -#if (3 != 0) - integer :: flags(size(mask,1),& -size(mask,2),& -size(mask,3)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_3d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_4d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:,:,:) - integer :: loc_vec(4) - -#if (4 != 0) - integer :: flags(size(mask,1),& -size(mask,2),& -size(mask,3),& -size(mask,4)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_4d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_5d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:,:,:,:) - integer :: loc_vec(5) - -#if (5 != 0) - integer :: flags(size(mask,1),& -size(mask,2),& -size(mask,3),& -size(mask,4),& -size(mask,5)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_5d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_6d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:,:,:,:,:) - integer :: loc_vec(6) - -#if (6 != 0) - integer :: flags(size(mask,1),& -size(mask,2),& -size(mask,3),& -size(mask,4),& -size(mask,5),& -size(mask,6)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_6d -! DIMS 0,1,2,3,4,5,6,7 -# 375 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -pure function find_first_loc_7d(mask) result (loc_vec) - ! Inefficient but simple subroutine for finding the location of - ! the first .true. value in an array. - ! If no true values, returns first value. - - logical, intent(in) :: mask(:,:,:,:,:,:,:) - integer :: loc_vec(7) - -#if (7 != 0) - integer :: flags(size(mask,1),& -size(mask,2),& -size(mask,3),& -size(mask,4),& -size(mask,5),& -size(mask,6),& -size(mask,7)) - - where (mask) - flags = 1 - elsewhere - flags = 0 - end where - - loc_vec = maxloc(flags) -#else - -! Remove compiler warnings (statement will be optimized out). - -#if (! defined CPRPGI && ! defined CPRCRAY) - if (.false. .and. mask) loc_vec = loc_vec -#endif - -#endif - -# 403 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function find_first_loc_7d - -! TYPE double,real,int,long -# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -elemental function within_tolerance_double(expected, actual, tolerance) & - result(is_in_tol) - ! Precondition: tolerance must be >= 0. - real(r8), intent(in) :: expected - real(r8), intent(in) :: actual - real(r8), intent(in) :: tolerance - logical :: is_in_tol - - ! The following conditionals are to ensure that we don't overflow. - - ! This takes care of two identical infinities. - if (actual == expected) then - is_in_tol = .true. - else if (actual > expected) then - if (expected >= 0) then - is_in_tol = (actual - expected) <= tolerance - else - is_in_tol = actual <= (expected + tolerance) - end if - else - if (expected < 0) then - is_in_tol = (expected - actual) <= tolerance - else - is_in_tol = actual >= (expected - tolerance) - end if - end if - -# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function within_tolerance_double -! TYPE double,real,int,long -# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -elemental function within_tolerance_real(expected, actual, tolerance) & - result(is_in_tol) - ! Precondition: tolerance must be >= 0. - real(r4), intent(in) :: expected - real(r4), intent(in) :: actual - real(r4), intent(in) :: tolerance - logical :: is_in_tol - - ! The following conditionals are to ensure that we don't overflow. - - ! This takes care of two identical infinities. - if (actual == expected) then - is_in_tol = .true. - else if (actual > expected) then - if (expected >= 0) then - is_in_tol = (actual - expected) <= tolerance - else - is_in_tol = actual <= (expected + tolerance) - end if - else - if (expected < 0) then - is_in_tol = (expected - actual) <= tolerance - else - is_in_tol = actual >= (expected - tolerance) - end if - end if - -# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function within_tolerance_real -! TYPE double,real,int,long -# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -elemental function within_tolerance_int(expected, actual, tolerance) & - result(is_in_tol) - ! Precondition: tolerance must be >= 0. - integer(i4), intent(in) :: expected - integer(i4), intent(in) :: actual - integer(i4), intent(in) :: tolerance - logical :: is_in_tol - - ! The following conditionals are to ensure that we don't overflow. - - ! This takes care of two identical infinities. - if (actual == expected) then - is_in_tol = .true. - else if (actual > expected) then - if (expected >= 0) then - is_in_tol = (actual - expected) <= tolerance - else - is_in_tol = actual <= (expected + tolerance) - end if - else - if (expected < 0) then - is_in_tol = (expected - actual) <= tolerance - else - is_in_tol = actual >= (expected - tolerance) - end if - end if - -# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function within_tolerance_int -! TYPE double,real,int,long -# 406 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -elemental function within_tolerance_long(expected, actual, tolerance) & - result(is_in_tol) - ! Precondition: tolerance must be >= 0. - integer(i8), intent(in) :: expected - integer(i8), intent(in) :: actual - integer(i8), intent(in) :: tolerance - logical :: is_in_tol - - ! The following conditionals are to ensure that we don't overflow. - - ! This takes care of two identical infinities. - if (actual == expected) then - is_in_tol = .true. - else if (actual > expected) then - if (expected >= 0) then - is_in_tol = (actual - expected) <= tolerance - else - is_in_tol = actual <= (expected + tolerance) - end if - else - if (expected < 0) then - is_in_tol = (expected - actual) <= tolerance - else - is_in_tol = actual >= (expected - tolerance) - end if - end if - -# 433 "/home/user/Projects/CAMDEN/cime/src/share/util/shr_assert_mod.F90.in" -end function within_tolerance_long - -end module shr_assert_mod diff --git a/test/include/shr_infnan_mod.F90 b/test/include/shr_infnan_mod.F90 index 575838ce..8863882d 100644 --- a/test/include/shr_infnan_mod.F90 +++ b/test/include/shr_infnan_mod.F90 @@ -1,8 +1,6 @@ -#include "dtypes.h" -!=================================================== -! DO NOT EDIT THIS FILE, it was generated using /home/user/Projects/CAMDEN/cime/src/externals/genf90/genf90.pl -! Any changes you make to this file may be lost +! This file is a stand-in for CIME's shr_infnan_mod.F90.in !=================================================== + ! Flag representing compiler support of Fortran 2003's ! ieee_arithmetic intrinsic module. #if defined CPRIBM || defined CPRPGI || defined CPRINTEL || defined CPRCRAY || defined CPRNAG @@ -71,6 +69,7 @@ module shr_infnan_mod ! Locally defined isnan. #ifndef HAVE_IEEE_ARITHMETIC + interface shr_infnan_isnan ! TYPE double,real module procedure shr_infnan_isnan_double @@ -79,6 +78,7 @@ module shr_infnan_mod end interface #endif + interface shr_infnan_isinf ! TYPE double,real module procedure shr_infnan_isinf_double @@ -86,6 +86,7 @@ module shr_infnan_mod module procedure shr_infnan_isinf_real end interface + interface shr_infnan_isposinf ! TYPE double,real module procedure shr_infnan_isposinf_double @@ -93,6 +94,7 @@ module shr_infnan_mod module procedure shr_infnan_isposinf_real end interface + interface shr_infnan_isneginf ! TYPE double,real module procedure shr_infnan_isneginf_double @@ -120,6 +122,7 @@ module shr_infnan_mod end type shr_infnan_inf_type ! Allow assigning reals to NaN or Inf. + interface assignment(=) ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 @@ -220,11 +223,13 @@ module shr_infnan_mod end interface ! Conversion functions. + interface shr_infnan_to_r8 module procedure nan_r8 module procedure inf_r8 end interface + interface shr_infnan_to_r4 module procedure nan_r4 module procedure inf_r4 @@ -265,6 +270,7 @@ module shr_infnan_mod integer(i8), parameter :: dneginf_pat = ibset(dposinf_pat,bit_size(1_i8)-1) #endif + contains !--------------------------------------------------------------------- @@ -274,20 +280,24 @@ module shr_infnan_mod !--------------------------------------------------------------------- ! TYPE double,real + elemental function shr_infnan_isinf_double(x) result(isinf) real(r8), intent(in) :: x logical :: isinf isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) + end function shr_infnan_isinf_double ! TYPE double,real + elemental function shr_infnan_isinf_real(x) result(isinf) real(r4), intent(in) :: x logical :: isinf isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) + end function shr_infnan_isinf_real #ifdef HAVE_IEEE_ARITHMETIC @@ -299,6 +309,7 @@ end function shr_infnan_isinf_real !--------------------------------------------------------------------- ! TYPE double,real + elemental function shr_infnan_isposinf_double(x) result(isposinf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -309,8 +320,10 @@ elemental function shr_infnan_isposinf_double(x) result(isposinf) isposinf = (ieee_positive_inf == ieee_class(x)) + end function shr_infnan_isposinf_double ! TYPE double,real + elemental function shr_infnan_isposinf_real(x) result(isposinf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -321,9 +334,11 @@ elemental function shr_infnan_isposinf_real(x) result(isposinf) isposinf = (ieee_positive_inf == ieee_class(x)) + end function shr_infnan_isposinf_real ! TYPE double,real + elemental function shr_infnan_isneginf_double(x) result(isneginf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -334,8 +349,10 @@ elemental function shr_infnan_isneginf_double(x) result(isneginf) isneginf = (ieee_negative_inf == ieee_class(x)) + end function shr_infnan_isneginf_double ! TYPE double,real + elemental function shr_infnan_isneginf_real(x) result(isneginf) use, intrinsic :: ieee_arithmetic, only: & ieee_class, & @@ -346,6 +363,7 @@ elemental function shr_infnan_isneginf_real(x) result(isneginf) isneginf = (ieee_negative_inf == ieee_class(x)) + end function shr_infnan_isneginf_real #else @@ -354,20 +372,24 @@ end function shr_infnan_isneginf_real #ifdef CPRGNU ! NaN testing on gfortran. ! TYPE double,real + elemental function shr_infnan_isnan_double(x) result(is_nan) real(r8), intent(in) :: x logical :: is_nan is_nan = isnan(x) + end function shr_infnan_isnan_double ! TYPE double,real + elemental function shr_infnan_isnan_real(x) result(is_nan) real(r4), intent(in) :: x logical :: is_nan is_nan = isnan(x) + end function shr_infnan_isnan_real ! End GNU section. #endif @@ -378,6 +400,7 @@ end function shr_infnan_isnan_real !--------------------------------------------------------------------- ! TYPE double,real + elemental function shr_infnan_isposinf_double(x) result(isposinf) real(r8), intent(in) :: x logical :: isposinf @@ -389,8 +412,10 @@ elemental function shr_infnan_isposinf_double(x) result(isposinf) isposinf = (x == transfer(posinf_pat,x)) + end function shr_infnan_isposinf_double ! TYPE double,real + elemental function shr_infnan_isposinf_real(x) result(isposinf) real(r4), intent(in) :: x logical :: isposinf @@ -402,9 +427,11 @@ elemental function shr_infnan_isposinf_real(x) result(isposinf) isposinf = (x == transfer(posinf_pat,x)) + end function shr_infnan_isposinf_real ! TYPE double,real + elemental function shr_infnan_isneginf_double(x) result(isneginf) real(r8), intent(in) :: x logical :: isneginf @@ -416,8 +443,10 @@ elemental function shr_infnan_isneginf_double(x) result(isneginf) isneginf = (x == transfer(neginf_pat,x)) + end function shr_infnan_isneginf_double ! TYPE double,real + elemental function shr_infnan_isneginf_real(x) result(isneginf) real(r4), intent(in) :: x logical :: isneginf @@ -429,6 +458,7 @@ elemental function shr_infnan_isneginf_real(x) result(isneginf) isneginf = (x == transfer(neginf_pat,x)) + end function shr_infnan_isneginf_real ! End ieee_arithmetic conditional. @@ -452,6 +482,7 @@ end function shr_infnan_isneginf_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_0d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -490,9 +521,11 @@ pure subroutine set_nan_0d_double(output, nan) output = tmp + end subroutine set_nan_0d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_1d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -531,9 +564,11 @@ pure subroutine set_nan_1d_double(output, nan) output = tmp + end subroutine set_nan_1d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_2d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -572,9 +607,11 @@ pure subroutine set_nan_2d_double(output, nan) output = tmp + end subroutine set_nan_2d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_3d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -613,9 +650,11 @@ pure subroutine set_nan_3d_double(output, nan) output = tmp + end subroutine set_nan_3d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_4d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -654,9 +693,11 @@ pure subroutine set_nan_4d_double(output, nan) output = tmp + end subroutine set_nan_4d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_5d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -695,9 +736,11 @@ pure subroutine set_nan_5d_double(output, nan) output = tmp + end subroutine set_nan_5d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_6d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -736,9 +779,11 @@ pure subroutine set_nan_6d_double(output, nan) output = tmp + end subroutine set_nan_6d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_7d_double(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -777,9 +822,11 @@ pure subroutine set_nan_7d_double(output, nan) output = tmp + end subroutine set_nan_7d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_0d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -818,9 +865,11 @@ pure subroutine set_nan_0d_real(output, nan) output = tmp + end subroutine set_nan_0d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_1d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -859,9 +908,11 @@ pure subroutine set_nan_1d_real(output, nan) output = tmp + end subroutine set_nan_1d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_2d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -900,9 +951,11 @@ pure subroutine set_nan_2d_real(output, nan) output = tmp + end subroutine set_nan_2d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_3d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -941,9 +994,11 @@ pure subroutine set_nan_3d_real(output, nan) output = tmp + end subroutine set_nan_3d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_4d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -982,9 +1037,11 @@ pure subroutine set_nan_4d_real(output, nan) output = tmp + end subroutine set_nan_4d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_5d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1023,9 +1080,11 @@ pure subroutine set_nan_5d_real(output, nan) output = tmp + end subroutine set_nan_5d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_6d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1064,9 +1123,11 @@ pure subroutine set_nan_6d_real(output, nan) output = tmp + end subroutine set_nan_6d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_nan_7d_real(output, nan) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1105,10 +1166,12 @@ pure subroutine set_nan_7d_real(output, nan) output = tmp + end subroutine set_nan_7d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_0d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1147,9 +1210,11 @@ pure subroutine set_inf_0d_double(output, inf) output = tmp + end subroutine set_inf_0d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_1d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1188,9 +1253,11 @@ pure subroutine set_inf_1d_double(output, inf) output = tmp + end subroutine set_inf_1d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_2d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1229,9 +1296,11 @@ pure subroutine set_inf_2d_double(output, inf) output = tmp + end subroutine set_inf_2d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_3d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1270,9 +1339,11 @@ pure subroutine set_inf_3d_double(output, inf) output = tmp + end subroutine set_inf_3d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_4d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1311,9 +1382,11 @@ pure subroutine set_inf_4d_double(output, inf) output = tmp + end subroutine set_inf_4d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_5d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1352,9 +1425,11 @@ pure subroutine set_inf_5d_double(output, inf) output = tmp + end subroutine set_inf_5d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_6d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1393,9 +1468,11 @@ pure subroutine set_inf_6d_double(output, inf) output = tmp + end subroutine set_inf_6d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_7d_double(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1434,9 +1511,11 @@ pure subroutine set_inf_7d_double(output, inf) output = tmp + end subroutine set_inf_7d_double ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_0d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1475,9 +1554,11 @@ pure subroutine set_inf_0d_real(output, inf) output = tmp + end subroutine set_inf_0d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_1d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1516,9 +1597,11 @@ pure subroutine set_inf_1d_real(output, inf) output = tmp + end subroutine set_inf_1d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_2d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1557,9 +1640,11 @@ pure subroutine set_inf_2d_real(output, inf) output = tmp + end subroutine set_inf_2d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_3d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1598,9 +1683,11 @@ pure subroutine set_inf_3d_real(output, inf) output = tmp + end subroutine set_inf_3d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_4d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1639,9 +1726,11 @@ pure subroutine set_inf_4d_real(output, inf) output = tmp + end subroutine set_inf_4d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_5d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1680,9 +1769,11 @@ pure subroutine set_inf_5d_real(output, inf) output = tmp + end subroutine set_inf_5d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_6d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1721,9 +1812,11 @@ pure subroutine set_inf_6d_real(output, inf) output = tmp + end subroutine set_inf_6d_real ! TYPE double,real ! DIMS 0,1,2,3,4,5,6,7 + pure subroutine set_inf_7d_real(output, inf) #ifdef HAVE_IEEE_ARITHMETIC use, intrinsic :: ieee_arithmetic, only: & @@ -1762,6 +1855,7 @@ pure subroutine set_inf_7d_real(output, inf) output = tmp + end subroutine set_inf_7d_real !--------------------------------------------------------------------- @@ -1770,36 +1864,44 @@ end subroutine set_inf_7d_real ! Function methods to get reals from nan/inf types. !--------------------------------------------------------------------- + pure function nan_r8(nan) result(output) class(shr_infnan_nan_type), intent(in) :: nan real(r8) :: output output = nan + end function nan_r8 + pure function nan_r4(nan) result(output) class(shr_infnan_nan_type), intent(in) :: nan real(r4) :: output output = nan + end function nan_r4 + pure function inf_r8(inf) result(output) class(shr_infnan_inf_type), intent(in) :: inf real(r8) :: output output = inf + end function inf_r8 + pure function inf_r4(inf) result(output) class(shr_infnan_inf_type), intent(in) :: inf real(r4) :: output output = inf + end function inf_r4 end module shr_infnan_mod diff --git a/test/include/shr_kind_mod.F90 b/test/include/shr_kind_mod.F90 new file mode 100644 index 00000000..e9e7d170 --- /dev/null +++ b/test/include/shr_kind_mod.F90 @@ -0,0 +1,19 @@ +MODULE shr_kind_mod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real + integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real + integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real + integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer + integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer + integer,parameter :: SHR_KIND_IN = kind(1) ! native integer + integer,parameter :: SHR_KIND_CS = 80 ! short char + integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char + integer,parameter :: SHR_KIND_CL = 256 ! long char + integer,parameter :: SHR_KIND_CX = 512 ! extra-long char + integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char + +END MODULE shr_kind_mod diff --git a/test/include/shr_mem_mod.F90 b/test/include/shr_mem_mod.F90 deleted file mode 100644 index e0844891..00000000 --- a/test/include/shr_mem_mod.F90 +++ /dev/null @@ -1,63 +0,0 @@ -MODULE shr_mem_mod - - use shr_kind_mod, only : shr_kind_r8 - use shr_log_mod, only: s_logunit => shr_log_Unit - use shr_sys_mod, only: shr_sys_abort - - implicit none - private - - ! PUBLIC: Public interfaces - - public :: shr_mem_getusage, & - shr_mem_init - - ! PUBLIC: Public interfaces - - real(shr_kind_r8) :: mb_blk = 0.0_shr_kind_r8 - - !=============================================================================== -CONTAINS - !=============================================================================== - - subroutine shr_mem_init(prt, strbuf) - - implicit none - - !----- arguments ----- - - logical, optional :: prt - character(len=*), optional :: strbuf - !----- local ----- - - ! --- Memory stats --- - integer :: msize ! memory size (high water) - integer :: mrss0,mrss1,mrss2 ! temporary rss - integer :: mshare,mtext,mdatastack - logical :: lprt - integer :: ierr - - integer :: GPTLget_memusage - - real(shr_kind_r8),allocatable :: mem_tmp(:) - - character(*),parameter :: subname = "(shr_mem_init)" - !--------------------------------------------------- - - end subroutine shr_mem_init - - !=============================================================================== - - subroutine shr_mem_getusage(r_msize,r_mrss,prt) - - implicit none - - !----- arguments --- - real(shr_kind_r8) :: r_msize,r_mrss - logical, optional :: prt - - end subroutine shr_mem_getusage - - !=============================================================================== - -END MODULE shr_mem_mod diff --git a/test/include/shr_string_mod.F90 b/test/include/shr_string_mod.F90 deleted file mode 100644 index ba10295d..00000000 --- a/test/include/shr_string_mod.F90 +++ /dev/null @@ -1,1967 +0,0 @@ -! !MODULE: shr_string_mod -- string and list methods -! -! !DESCRIPTION: -! General string and specific list method. A list is a single string -! that is delimited by a character forming multiple fields, ie, -! character(len=*) :: mylist = "t:s:u1:v1:u2:v2:taux:tauy" -! The delimiter is called listDel in this module, is default ":", -! but can be set by a call to shr_string_listSetDel. -! -! !REVISION HISTORY: -! 2005-Apr-28 - T. Craig - first version -! -! !INTERFACE: ------------------------------------------------------------------ - -module shr_string_mod - - ! !USES: -#ifdef NDEBUG -#define SHR_ASSERT(assert, msg) -#define SHR_ASSERT_FL(assert, file, line) -#define SHR_ASSERT_MFL(assert, msg, file, line) -#define SHR_ASSERT_ALL(assert, msg) -#define SHR_ASSERT_ALL_FL(assert, file, line) -#define SHR_ASSERT_ALL_MFL(assert, msg, file, line) -#define SHR_ASSERT_ANY(assert, msg) -#define SHR_ASSERT_ANY_FL(assert, file, line) -#define SHR_ASSERT_ANY_MFL(assert, msg, file, line) -#else -#define SHR_ASSERT(assert, my_msg) call shr_assert(assert, msg=my_msg) -#define SHR_ASSERT_FL(assert, my_file, my_line) call shr_assert(assert, file=my_file, line=my_line) -#define SHR_ASSERT_MFL(assert, my_msg, my_file, my_line) call shr_assert(assert, msg=my_msg, file=my_file, line=my_line) -#define SHR_ASSERT_ALL(assert, my_msg) call shr_assert_all(assert, msg=my_msg) -#define SHR_ASSERT_ALL_FL(assert, my_file, my_line) call shr_assert_all(assert, file=my_file, line=my_line) -#define SHR_ASSERT_ALL_MFL(assert, my_msg, my_file, my_line) call shr_assert_all(assert, msg=my_msg, file=my_file, line=my_line) -#define SHR_ASSERT_ANY(assert, my_msg) call shr_assert_any(assert, msg=my_msg) -#define SHR_ASSERT_ANY_FL(assert, my_file, my_line) call shr_assert_any(assert, file=my_file, line=my_line) -#define SHR_ASSERT_ANY_MFL(assert, my_msg, my_file, my_line) call shr_assert_any(assert, msg=my_msg, file=my_file, line=my_line) -#endif - - use shr_assert_mod - use shr_kind_mod ! F90 kinds - use shr_sys_mod ! shared system calls - use shr_timer_mod, only : shr_timer_get, shr_timer_start, shr_timer_stop - use shr_log_mod, only : errMsg => shr_log_errMsg - use shr_log_mod, only : s_loglev => shr_log_Level - use shr_log_mod, only : s_logunit => shr_log_Unit - - implicit none - private - - ! !PUBLIC TYPES: - - ! no public types - - ! !PUBLIC MEMBER FUNCTIONS: - - public :: shr_string_countChar ! Count number of char in string, fn - public :: shr_string_toUpper ! Convert string to upper-case - public :: shr_string_toLower ! Convert string to lower-case - public :: shr_string_getParentDir ! For a pathname get the parent directory name - public :: shr_string_lastIndex ! Index of last substr in str - public :: shr_string_endIndex ! Index of end of substr in str - public :: shr_string_leftalign_and_convert_tabs ! remove leading white space and convert all tabs to spaces - public :: shr_string_convert_tabs ! Convert all tabs to spaces - public :: shr_string_alphanum ! remove all non alpha-numeric characters - public :: shr_string_betweenTags ! get the substring between the two tags - public :: shr_string_parseCFtunit ! parse CF time units - public :: shr_string_clean ! Set string to all white space - - public :: shr_string_listIsValid ! test for a valid "list" - public :: shr_string_listGetNum ! Get number of fields in list, fn - public :: shr_string_listGetIndex ! Get index of field - public :: shr_string_listGetIndexF ! function version of listGetIndex - public :: shr_string_listGetName ! get k-th field name - public :: shr_string_listIntersect ! get intersection of two field lists - public :: shr_string_listUnion ! get union of two field lists - public :: shr_string_listDiff ! get set difference of two field lists - public :: shr_string_listMerge ! merge two lists to form third - public :: shr_string_listAppend ! append list at end of another - public :: shr_string_listSetDel ! Set field delimiter in lists - public :: shr_string_listGetDel ! Get field delimiter in lists - public :: shr_string_listFromSuffixes! return colon delimited field list - ! given array of suffixes and a base string - public :: shr_string_listCreateField ! return colon delimited field list - ! given number of fields N and a base string - public :: shr_string_listAddSuffix ! add a suffix to every field in a field list - public :: shr_string_setAbort ! set local abort flag - public :: shr_string_setDebug ! set local debug flag - - ! !PUBLIC DATA MEMBERS: - - ! no public data members - - !EOP - - character(len=1) ,save :: listDel = ":" ! note single exec implications - character(len=2) ,save :: listDel2 = "::" ! note single exec implications - logical ,save :: doabort = .true. - integer(SHR_KIND_IN),save :: debug = 0 - - !=============================================================================== -contains - !=============================================================================== - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_countChar -- Count number of occurances of a character - ! - ! !DESCRIPTION: - ! count number of occurances of a single character in a string - ! \newline - ! n = shr\_string\_countChar(string,character) - ! - ! !REVISION HISTORY: - ! 2005-Feb-28 - First version from dshr_bundle - ! - ! !INTERFACE: ------------------------------------------------------------------ - - integer function shr_string_countChar(str,char,rc) - - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: str ! string to search - character(1) ,intent(in) :: char ! char to search for - integer(SHR_KIND_IN),intent(out),optional :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: count ! counts occurances of char - integer(SHR_KIND_IN) :: n ! generic index - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_countChar) " - character(*),parameter :: F00 = "('(shr_string_countChar) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - count = 0 - do n = 1, len_trim(str) - if (str(n:n) == char) count = count + 1 - end do - shr_string_countChar = count - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_countChar - - !=============================================================================== - !BOP =========================================================================== - ! !IROUTINE: shr_string_toUpper -- Convert string to upper case - ! - ! !DESCRIPTION: - ! Convert the input string to upper-case. - ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. - ! - ! !REVISION HISTORY: - ! 2005-Dec-20 - Move CAM version over to shared code. - ! - ! !INTERFACE: ------------------------------------------------------------------ - - function shr_string_toUpper(str) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - character(len=*), intent(in) :: str ! String to convert to upper case - character(len=len(str)) :: shr_string_toUpper - - !----- local ----- - integer(SHR_KIND_IN) :: i ! Index - integer(SHR_KIND_IN) :: aseq ! ascii collating sequence - integer(SHR_KIND_IN) :: LowerToUpper ! integer to convert case - character(len=1) :: ctmp ! Character temporary - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_toUpper) " - character(*),parameter :: F00 = "('(shr_string_toUpper) ',4a)" - - !------------------------------------------------------------------------------- - ! - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - LowerToUpper = iachar("A") - iachar("a") - - do i = 1, len(str) - ctmp = str(i:i) - aseq = iachar(ctmp) - if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & - ctmp = achar(aseq + LowertoUpper) - shr_string_toUpper(i:i) = ctmp - end do - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_toUpper - - !=============================================================================== - !BOP =========================================================================== - ! !IROUTINE: shr_string_toLower -- Convert string to lower case - ! - ! !DESCRIPTION: - ! Convert the input string to lower-case. - ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. - ! - ! !REVISION HISTORY: - ! 2006-Apr-20 - Creation - ! - ! !INTERFACE: ------------------------------------------------------------------ - function shr_string_toLower(str) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - character(len=*), intent(in) :: str ! String to convert to lower case - character(len=len(str)) :: shr_string_toLower - - !----- local ----- - integer(SHR_KIND_IN) :: i ! Index - integer(SHR_KIND_IN) :: aseq ! ascii collating sequence - integer(SHR_KIND_IN) :: UpperToLower ! integer to convert case - character(len=1) :: ctmp ! Character temporary - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_toLower) " - character(*),parameter :: F00 = "('(shr_string_toLower) ',4a)" - - !------------------------------------------------------------------------------- - ! - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - UpperToLower = iachar("a") - iachar("A") - - do i = 1, len(str) - ctmp = str(i:i) - aseq = iachar(ctmp) - if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & - ctmp = achar(aseq + UpperToLower) - shr_string_toLower(i:i) = ctmp - end do - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_toLower - - !=============================================================================== - !BOP =========================================================================== - ! !IROUTINE: shr_string_getParentDir -- For pathname get the parent directory name - ! - ! !DESCRIPTION: - ! Get the parent directory name for a pathname. - ! - ! !REVISION HISTORY: - ! 2006-May-09 - Creation - ! - ! !INTERFACE: ------------------------------------------------------------------ - - function shr_string_getParentDir(str) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - character(len=*), intent(in) :: str ! String to convert to lower case - character(len=len(str)) :: shr_string_getParentDir - - !----- local ----- - integer(SHR_KIND_IN) :: i ! Index - integer(SHR_KIND_IN) :: nlen ! Length of string - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_getParentDir) " - character(*),parameter :: F00 = "('(shr_string_getParentDir) ',4a)" - - !------------------------------------------------------------------------------- - ! - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - nlen = len_trim(str) - if ( str(nlen:nlen) == "/" ) nlen = nlen - 1 - i = index( str(1:nlen), "/", back=.true. ) - if ( i == 0 )then - shr_string_getParentDir = str - else - shr_string_getParentDir = str(1:i-1) - end if - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_getParentDir - - !=============================================================================== - !BOP =========================================================================== - ! - ! - ! !IROUTINE: shr_string_lastIndex -- Get index of last substr within string - ! - ! !DESCRIPTION: - ! Get index of last substr within string - ! \newline - ! n = shr\_string\_lastIndex(string,substring) - ! - ! !REVISION HISTORY: - ! 2005-Feb-28 - First version from dshr_domain - ! - ! !INTERFACE: ------------------------------------------------------------------ - - integer function shr_string_lastIndex(string,substr,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: string ! string to search - character(*) ,intent(in) :: substr ! sub-string to search for - integer(SHR_KIND_IN),intent(out),optional :: rc ! return code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_lastIndex) " - character(*),parameter :: F00 = "('(shr_string_lastIndex) ',4a)" - - !------------------------------------------------------------------------------- - ! Note: - ! - "new" F90 back option to index function makes this home-grown solution obsolete - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - shr_string_lastIndex = index(string,substr,.true.) - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_lastIndex - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_endIndex -- Get the ending index of substr within string - ! - ! !DESCRIPTION: - ! Get the ending index of substr within string - ! \newline - ! n = shr\_string\_endIndex(string,substring) - ! - ! !REVISION HISTORY: - ! 2005-May-10 - B. Kauffman, first version. - ! - ! !INTERFACE: ------------------------------------------------------------------ - - integer function shr_string_endIndex(string,substr,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: string ! string to search - character(*) ,intent(in) :: substr ! sub-string to search for - integer(SHR_KIND_IN),intent(out),optional :: rc ! return code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: i ! generic index - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_endIndex) " - character(*),parameter :: F00 = "('(shr_string_endIndex) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! * returns zero if substring not found, uses len_trim() intrinsic - ! * very similar to: i = index(str,substr,back=.true.) - ! * do we need this function? - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - i = index(trim(string),trim(substr)) - if ( i == 0 ) then - shr_string_endIndex = 0 ! substr is not in string - else - shr_string_endIndex = i + len_trim(substr) - 1 - end if - - ! ------------------------------------------------------------------- - ! i = index(trim(string),trim(substr),back=.true.) - ! if (i == len(string)+1) i = 0 - ! shr_string_endIndex = i - ! ------------------------------------------------------------------- - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_endIndex - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_leftalign_and_convert_tabs -- remove leading white space and - ! convert tabs to spaces - ! - ! !DESCRIPTION: - ! Remove leading white space (spaces and tabs) and convert tabs to spaces - ! This even converts tabs in the middle or at the end of the string to spaces - ! \newline - ! call shr\_string\_leftalign_and_convert_tabs(string) - ! - ! !REVISION HISTORY: - ! 2005-Apr-28 - B. Kauffman - First version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_leftalign_and_convert_tabs(str,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(inout) :: str - integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code - - !EOP - - !----- local ---- - integer(SHR_KIND_IN) :: t01 = 0 ! timer - character, parameter :: tab_char = char(9) - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_leftalign_and_convert_tabs) " - character(*),parameter :: F00 = "('(shr_string_leftalign_and_convert_tabs) ',4a)" - - !------------------------------------------------------------------------------- - ! - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - ! First convert tabs to white space in the string - str = shr_string_convert_tabs(str, rc) - - ! Now remove the leading white space - str = adjustL(str) - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_leftalign_and_convert_tabs - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_convert_tabs -- convert all tabs to spaces - ! - ! !DESCRIPTION: - ! Convert all tabs to spaces in the given string - ! - ! !REVISION HISTORY: - ! 2017-May- - M. Vertenstein - ! - ! !INTERFACE: ------------------------------------------------------------------ - - function shr_string_convert_tabs(str_input,rc) result(str_output) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(len=*) ,intent(in) :: str_input - integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code - character(len=len(str_input)) :: str_output - !EOP - - !----- local ---- - integer(SHR_KIND_IN) :: inlength, i ! temporaries - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_remove_tabs) " - character(*),parameter :: F00 = "('(shr_string_remove_tabs) ',4a)" - - ! note that tab is achar(9) - inlength = len(str_input) - str_output = '' - do i = 1, inlength - if (str_input(i:i) == achar(9)) then - str_output(i:i) = ' ' - else - str_output(i:i) = str_input(i:i) - end if - end do - - if (present(rc)) rc = 0 - - end function shr_string_convert_tabs - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_alphanum -- remove non alpha numeric characters - ! - ! !DESCRIPTION: - ! Remove all non alpha numeric characters from string - ! \newline - ! call shr\_string\_alphanum(string) - ! - ! !REVISION HISTORY: - ! 2005-Aug-01 - T. Craig - First version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_alphanum(str,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(inout) :: str - integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code - - !EOP - - !----- local ---- - integer(SHR_KIND_IN) :: n,icnt ! counters - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_alphaNum) " - character(*),parameter :: F00 = "('(shr_string_alphaNum) ',4a)" - - !------------------------------------------------------------------------------- - ! - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - icnt = 0 - do n=1,len_trim(str) - if ((str(n:n) >= 'a' .and. str(n:n) <= 'z') .or. & - (str(n:n) >= 'A' .and. str(n:n) <= 'Z') .or. & - (str(n:n) >= '0' .and. str(n:n) <= '9')) then - icnt = icnt + 1 - str(icnt:icnt) = str(n:n) - endif - enddo - do n=icnt+1,len(str) - str(n:n) = ' ' - enddo - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_alphanum - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_betweenTags -- Get the substring between the two tags. - ! - ! !DESCRIPTION: - ! Get the substring found between the start and end tags. - ! \newline - ! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc) - ! - ! !REVISION HISTORY: - ! 2005-May-11 - B. Kauffman, first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_betweenTags(string,startTag,endTag,substr,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: string ! string to search - character(*) ,intent(in) :: startTag ! start tag - character(*) ,intent(in) :: endTag ! end tag - character(*) ,intent(out) :: substr ! sub-string between tags - integer(SHR_KIND_IN),intent(out),optional :: rc ! retrun code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: iStart ! substring start index - integer(SHR_KIND_IN) :: iEnd ! substring end index - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_betweenTags) " - character(*),parameter :: F00 = "('(shr_string_betweenTags) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! * assumes the leading/trailing white space is not part of start & end tags - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - iStart = shr_string_endIndex(string,trim(adjustL(startTag))) ! end of start tag - iEnd = index(string,trim(adjustL(endTag ))) ! start of end tag - - rCode = 0 - substr = "" - - if (iStart < 1) then - if (s_loglev > 0) then - write(s_logunit,F00) "ERROR: can't find start tag in string" - write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) - write(s_logunit,F00) "ERROR: string = ",trim(string) - endif - rCode = 1 - else if (iEnd < 1) then - if (s_loglev > 0) then - write(s_logunit,F00) "ERROR: can't find end tag in string" - write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) - write(s_logunit,F00) "ERROR: string = ",trim(string) - endif - rCode = 2 - else if ( iEnd <= iStart) then - if (s_loglev > 0) then - write(s_logunit,F00) "ERROR: start tag not before end tag" - write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) - write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) - write(s_logunit,F00) "ERROR: string = ",trim(string) - endif - rCode = 3 - else if ( iStart+1 == iEnd ) then - substr = "" - if (s_loglev > 0) write(s_logunit,F00) "WARNING: zero-length substring found in ",trim(string) - else - substr = string(iStart+1:iEnd-1) - if (len_trim(substr) == 0 .and. s_loglev > 0) & - & write(s_logunit,F00) "WARNING: white-space substring found in ",trim(string) - end if - - if (present(rc)) rc = rCode - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_betweenTags - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_parseCFtunit -- Parse CF time unit - ! - ! !DESCRIPTION: - ! Parse CF time unit into a delta string name and a base time in yyyymmdd - ! and seconds (nearest integer actually). - ! \newline - ! call shr\_string\_parseCFtunit(string,substring) - ! \newline - ! Input string is like "days since 0001-06-15 15:20:45.5 -6:00" - ! - recognizes "days", "hours", "minutes", "seconds" - ! - must have at least yyyy-mm-dd, hh:mm:ss.s is optional - ! - expects a "since" in the string - ! - ignores time zone part - ! - ! !REVISION HISTORY: - ! 2005-May-15 - T. Craig - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_parseCFtunit(string,unit,bdate,bsec,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: string ! string to search - character(*) ,intent(out) :: unit ! delta time unit - integer(SHR_KIND_IN),intent(out) :: bdate ! base date yyyymmdd - real(SHR_KIND_R8) ,intent(out) :: bsec ! base seconds - integer(SHR_KIND_IN),intent(out),optional :: rc ! return code - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: i,i1,i2 ! generic index - character(SHR_KIND_CL) :: tbase ! baseline time - character(SHR_KIND_CL) :: lstr ! local string - integer(SHR_KIND_IN) :: yr,mo,da,hr,min ! time stuff - real(SHR_KIND_R8) :: sec ! time stuff - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_parseCFtunit) " - character(*),parameter :: F00 = "('(shr_string_parseCFtunit) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! o assume length of CF-1.0 time attribute char string < SHR_KIND_CL - ! This is a reasonable assumption. - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - unit = 'none' - bdate = 0 - bsec = 0.0_SHR_KIND_R8 - - i = shr_string_lastIndex(string,'days ') - if (i > 0) unit = 'days' - i = shr_string_lastIndex(string,'hours ') - if (i > 0) unit = 'hours' - i = shr_string_lastIndex(string,'minutes ') - if (i > 0) unit = 'minutes' - i = shr_string_lastIndex(string,'seconds ') - if (i > 0) unit = 'seconds' - - if (trim(unit) == 'none') then - write(s_logunit,F00) ' ERROR time unit unknown' - call shr_string_abort(subName//' time unit unknown') - endif - - i = shr_string_lastIndex(string,' since ') - if (i < 1) then - write(s_logunit,F00) ' ERROR since does not appear in unit attribute for time ' - call shr_string_abort(subName//' no since in attr name') - endif - tbase = trim(string(i+6:)) - call shr_string_leftalign_and_convert_tabs(tbase) - - if (debug > 0 .and. s_logunit > 0) then - write(s_logunit,*) trim(subName)//' '//'unit '//trim(unit) - write(s_logunit,*) trim(subName)//' '//'tbase '//trim(tbase) - endif - - yr=0; mo=0; da=0; hr=0; min=0; sec=0 - i1 = 1 - - i2 = index(tbase,'-') - 1 - if(i2<0) goto 200 - lstr = tbase(i1:i2) - - read(lstr,*,ERR=200,END=200) yr - tbase = tbase(i2+2:) - call shr_string_leftalign_and_convert_tabs(tbase) - - i2 = index(tbase,'-') - 1 - if(i2<0) goto 200 - lstr = tbase(i1:i2) - read(lstr,*,ERR=200,END=200) mo - tbase = tbase(i2+2:) - call shr_string_leftalign_and_convert_tabs(tbase) - - i2 = index(tbase,' ') - 1 - if(i2<0) i2= len_trim(tbase) - lstr = tbase(i1:i2) - read(lstr,*,ERR=200,END=200) da - tbase = tbase(i2+2:) - call shr_string_leftalign_and_convert_tabs(tbase) - - i2 = index(tbase,':') - 1 - if(i2<0) i2=len_trim(tbase) - lstr = tbase(i1:i2) - read(lstr,*,ERR=200,END=100) hr - tbase = tbase(i2+2:) - call shr_string_leftalign_and_convert_tabs(tbase) - - i2 = index(tbase,':') - 1 - if(i2<0) i2=len_trim(tbase) - lstr = tbase(i1:i2) - read(lstr,*,ERR=200,END=100) min - tbase = tbase(i2+2:) - call shr_string_leftalign_and_convert_tabs(tbase) - - i2 = index(tbase,' ') - 1 - if(i2<0) i2=len_trim(tbase) - lstr = tbase(i1:i2) - read(lstr,*,ERR=200,END=100) sec - -100 continue - if (debug > 0 .and. s_loglev > 0) write(s_logunit,*) trim(subName),'ymdhms:',yr,mo,da,hr,min,sec - - bdate = abs(yr)*10000 + mo*100 + da - if (yr < 0) bdate = -bdate - bsec = real(hr*3600 + min*60,SHR_KIND_R8) + sec - - if (present(rc)) rc = 0 - - if (debug>1) call shr_timer_stop (t01) - return - -200 continue - write(s_logunit,F00) 'ERROR 200 on char num read ' - call shr_string_abort(subName//' ERROR on char num read') - if (debug>1) call shr_timer_stop (t01) - return - - end subroutine shr_string_parseCFtunit - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_clean -- Clean a string, set it to "blank" - ! - ! !DESCRIPTION: - ! Clean a string, set it to blank - ! \newline - ! call shr\_string\_clean(string,rc) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_clean(string,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(inout) :: string ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_clean) " - character(*),parameter :: F00 = "('(shr_string_clean) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - rCode = 0 - string = ' ' - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_clean - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listIsValid -- determine whether string is a valid list - ! - ! !DESCRIPTION: - ! Determine whether string is a valid list - ! \newline - ! logical_var = shr\_string\_listIsValid(list,rc) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - B. Kauffman - ! - ! !INTERFACE: ------------------------------------------------------------------ - - logical function shr_string_listIsValid(list,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer (SHR_KIND_IN) :: nChar ! lenth of list - integer (SHR_KIND_IN) :: rCode ! return code - integer (SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listIsValid) " - character(*),parameter :: F00 = "('(shr_string_listIsValid) ',4a)" - - !------------------------------------------------------------------------------- - ! check that the list conforms to the list format - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - rCode = 0 - shr_string_listIsValid = .true. - - nChar = len_trim(list) - if (nChar < 1) then ! list is an empty string - rCode = 1 - else if ( list(1:1) == listDel ) then ! first char is delimiter - rCode = 2 - else if (list(nChar:nChar) == listDel ) then ! last char is delimiter - rCode = 3 - else if (index(trim(list)," " ) > 0) then ! white-space in a field name - rCode = 4 - else if (index(trim(list),listDel2) > 0) then ! found zero length field - rCode = 5 - end if - - if (rCode /= 0) then - shr_string_listIsValid = .false. - if (s_loglev > 0) write(s_logunit,F00) "WARNING: invalid list = ",trim(list) - endif - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_listIsValid - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listGetName -- Get name of k-th field in list - ! - ! !DESCRIPTION: - ! Get name of k-th field in list - ! \newline - ! call shr\_string\_listGetName(list,k,name,rc) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - B. Kauffman - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listGetName(list,k,name,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list ! list/string - integer(SHR_KIND_IN) ,intent(in) :: k ! index of field - character(*) ,intent(out) :: name ! k-th name in list - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: i,n ! generic indecies - integer(SHR_KIND_IN) :: kFlds ! number of fields in list - integer(SHR_KIND_IN) :: i0,i1 ! name = list(i0:i1) - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listGetName) " - character(*),parameter :: F00 = "('(shr_string_listGetName) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - rCode = 0 - - !--- check that this is a valid list --- - if (.not. shr_string_listIsValid(list,rCode) ) then - write(s_logunit,F00) "ERROR: invalid list = ",trim(list) - call shr_string_abort(subName//" ERROR: invalid list = "//trim(list)) - end if - - !--- check that this is a valid index --- - kFlds = shr_string_listGetNum(list) - if (k<1 .or. kFlds1) call shr_timer_stop (t01) - - end subroutine shr_string_listGetName - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listIntersect -- Get intersection of two field lists - ! - ! !DESCRIPTION: - ! Get intersection of two fields lists, write into third list - ! \newline - ! call shr\_string\_listIntersect(list1,list2,listout) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listIntersect(list1,list2,listout,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list1 ! list/string - character(*) ,intent(in) :: list2 ! list/string - character(*) ,intent(out) :: listout ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: nf,n1,n2 ! counters - character(SHR_KIND_CS) :: name ! field name - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listIntersect) " - character(*),parameter :: F00 = "('(shr_string_listIntersect) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - rCode = 0 - - nf = shr_string_listGetNum(list1) - call shr_string_clean(listout) - do n1 = 1,nf - call shr_string_listGetName(list1,n1,name,rCode) - n2 = shr_string_listGetIndexF(list2,name) - if (n2 > 0) then - call shr_string_listAppend(listout,name) - endif - enddo - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listIntersect - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listUnion -- Get union of two field lists - ! - ! !DESCRIPTION: - ! Get union of two fields lists, write into third list - ! \newline - ! call shr\_string\_listUnion(list1,list2,listout) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listUnion(list1,list2,listout,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list1 ! list/string - character(*) ,intent(in) :: list2 ! list/string - character(*) ,intent(out) :: listout ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: nf,n1,n2 ! counters - character(SHR_KIND_CS) :: name ! field name - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listUnion) " - character(*),parameter :: F00 = "('(shr_string_listUnion) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - rCode = 0 - - call shr_string_clean(listout) - - nf = shr_string_listGetNum(list1) - do n1 = 1,nf - call shr_string_listGetName(list1,n1,name,rCode) - n2 = shr_string_listGetIndexF(listout,name) - if (n2 < 1) then - call shr_string_listAppend(listout,name) - endif - enddo - - nf = shr_string_listGetNum(list2) - do n1 = 1,nf - call shr_string_listGetName(list2,n1,name,rCode) - n2 = shr_string_listGetIndexF(listout,name) - if (n2 < 1) then - call shr_string_listAppend(listout,name) - endif - enddo - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listUnion - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listDiff -- Get set difference of two field lists - ! - ! !DESCRIPTION: - ! Get set difference of two fields lists, write into third list - ! \newline - ! call shr\_string\_listDiff(list1,list2,listout) - ! \newline - ! listout will contain all elements in list1 but not in list2 - ! - ! !REVISION HISTORY: - ! 2015-April-24 - W. Sacks - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listDiff(list1,list2,listout,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list1 ! list/string - character(*) ,intent(in) :: list2 ! list/string - character(*) ,intent(out) :: listout ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: num_fields, index1, index2 - character(SHR_KIND_CS) :: name ! field name - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listDiff) " - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - rCode = 0 - - num_fields = shr_string_listGetNum(list1) - call shr_string_clean(listout) - do index1 = 1,num_fields - call shr_string_listGetName(list1,index1,name,rCode) - index2 = shr_string_listGetIndexF(list2,name) - if (index2 <= 0) then - call shr_string_listAppend(listout,name) - endif - enddo - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listDiff - - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listMerge -- Merge lists two list to third - ! - ! !DESCRIPTION: - ! Merge two list to third - ! \newline - ! call shr\_string\_listMerge(list1,list2,listout) - ! call shr\_string\_listMerge(list1,list2,list1) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listMerge(list1,list2,listout,rc) - - implicit none - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: list1 ! list/string - character(*) ,intent(in) :: list2 ! list/string - character(*) ,intent(out) :: listout ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - character(len=len(list1)) :: l1 - character(len=len(list2)) :: l2 - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listMerge) " - character(*),parameter :: F00 = "('(shr_string_listMerge) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! - no input or output string should be longer than SHR_KIND_CX - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - rCode = 0 - - call shr_string_clean(l1) - call shr_string_clean(l2) - call shr_string_clean(listout) - l1 = trim(list1) - l2 = trim(list2) - call shr_string_leftalign_and_convert_tabs(l1,rCode) - call shr_string_leftalign_and_convert_tabs(l2,rCode) - if (len_trim(l1)+len_trim(l2)+1 > len(listout)) & - call shr_string_abort(subName//'ERROR: output list string not large enough') - if (len_trim(l1) == 0) then - listout = trim(l2) - else - listout = trim(l1)//":"//trim(l2) - endif - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listMerge - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listAppend -- Append one list to another - ! - ! !DESCRIPTION: - ! Append one list to another - ! \newline - ! call shr\_string\_listAppend(list,listadd) - ! - ! !REVISION HISTORY: - ! 2005-May-05 - T. Craig - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listAppend(list,listadd,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(inout) :: list ! list/string - character(*) ,intent(in) :: listadd ! list/string - integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code - - !EOP - - !----- local ----- - character(SHR_KIND_CX) :: l1 ! local string - integer(SHR_KIND_IN) :: rCode ! return code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listAppend) " - character(*),parameter :: F00 = "('(shr_string_listAppend) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! - no input or output string should be longer than SHR_KIND_CX - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - rCode = 0 - - !--- make sure temp string is large enough --- - if (len(l1) < len_trim(listAdd)) then - call shr_string_abort(subName//'ERROR: temp string not large enough') - end if - - call shr_string_clean(l1) - l1 = trim(listadd) - call shr_string_leftalign_and_convert_tabs(l1,rCode) - if (len_trim(list)+len_trim(l1)+1 > len(list)) & - call shr_string_abort(subName//'ERROR: output list string not large enough') - if (len_trim(list) == 0) then - list = trim(l1) - else - list = trim(list)//":"//trim(l1) - endif - - if (present(rc)) rc = rCode - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listAppend - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listGetIndexF -- Get index of field in string - ! - ! !DESCRIPTION: - ! Get index of field in string - ! \newline - ! k = shr\_string\_listGetIndex(str,"taux") - ! - ! !REVISION HISTORY: - ! 2005-Feb-28 - B. Kauffman and J. Schramm - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - integer function shr_string_listGetIndexF(string,fldStr) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),intent(in) :: string ! string - character(*),intent(in) :: fldStr ! name of field - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: k ! local index variable - integer(SHR_KIND_IN) :: rc ! error code - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listGetIndexF) " - character(*),parameter :: F00 = "('(shr_string_listGetIndexF) ',4a)" - - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - call shr_string_listGetIndex(string,fldStr,k,print=.false.,rc=rc) - shr_string_listGetIndexF = k - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_listGetIndexF - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listGetIndex -- Get index of field in string - ! - ! !DESCRIPTION: - ! Get index of field in string - ! \newline - ! call shr\_string\_listGetIndex(str,"taux",k,rc) - ! - ! !REVISION HISTORY: - ! 2005-Feb-28 - B. Kauffman and J. Schramm - first version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listGetIndex(string,fldStr,kFld,print,rc) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*) ,intent(in) :: string ! string - character(*) ,intent(in) :: fldStr ! name of field - integer(SHR_KIND_IN),intent(out) :: kFld ! index of field - logical ,intent(in) ,optional :: print ! print switch - integer(SHR_KIND_IN),intent(out),optional :: rc ! return code - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: n ! index for colon position - integer(SHR_KIND_IN) :: k ! index for field name position - integer(SHR_KIND_IN) :: nFields ! number of fields in a string - integer(SHR_KIND_IN) :: i0,i1 ! fldStr == string(i0,i1) ?? - integer(SHR_KIND_IN) :: j0,j1 ! fldStr == string(j0,j1) ?? - logical :: found ! T => field found in fieldNames - logical :: lprint ! local print flag - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listGetIndex) " - character(*),parameter :: F00 = "('(shr_string_listGetIndex) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - ! - searching from both ends of the list at the same time seems to be 20% faster - ! but I'm not sure why (B. Kauffman, Feb 2007) - ! - I commented out sanity check to a little gain speed (B. Kauffman, Mar 2007) - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - if (present(rc)) rc = 0 - - lprint = .false. - if (present(print)) lprint = print - - !--- confirm proper size of input data --- - if (len_trim(fldStr) < 1) then - if (lprint) write(s_logunit,F00) "ERROR: input field name has 0 length" - call shr_string_abort(subName//"invalid field name") - end if - - !--- search for field name in string's list of fields --- - found = .false. - kFld = 0 - i0 = 1 ! ?? fldStr == string(i0:i1) ?? - i1 = -1 - j0 = -1 ! ?? fldStr == string(j0:j1) ?? - j1 = len_trim(string) - nFields = shr_string_listGetNum(string) - do k = 1,nFields - !-------------------------------------------------------- - ! search from end of list to end of list - !-------------------------------------------------------- - !--- get end index of of field number k --- - n = index(string(i0:len_trim(string)),listDel) - if (n > 0) then - i1 = i0 + n - 2 ! *not* the last field name in fieldNames - else - i1 = len_trim(string) ! this is the last field name in fieldNames - endif - !--- sanity check --- - ! if ((k 0)) then - ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") - ! end if - !--- is it a match? --- - if (trim(fldStr) == string(i0:i1)) then - found = .true. - kFld = k - exit - endif - i0 = i1 + 2 ! start index for next iteration - !-------------------------------------------------------- - ! search from end of list to start of list - !-------------------------------------------------------- - !--- get start index of field number (nFields + 1 - k ) --- - n = index(string(1:j1),listDel,back=.true.) - j0 = n + 1 ! n==0 => the first field name in fieldNames - !--- sanity check --- - ! if ((k 0)) then - ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") - ! end if - !--- is it a match? --- - if (trim(fldStr) == string(j0:j1)) then - found = .true. - kFld = nFields + 1 - k - exit - endif - j1 = j0 - 2 ! end index for next iteration - !-------------------------------------------------------- - ! exit if all field names have been checked - !-------------------------------------------------------- - if (2*k >= nFields) exit - end do - - !--- not finding a field is not a fatal error --- - if (.not. found) then - kFld = 0 - if (lprint .and. s_loglev > 0) write(s_logunit,F00) "FYI: field ",trim(fldStr)," not found in list ",trim(string) - if (present(rc)) rc = 1 - end if - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listGetIndex - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listGetNum -- get number of fields in a string list - ! - ! !DESCRIPTION: - ! return number of fields in string list - ! - ! !REVISION HISTORY: - ! 2005-Apr-28 - T. Craig - First version - ! - ! !INTERFACE: ------------------------------------------------------------------ - - integer function shr_string_listGetNum(str) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),intent(in) :: str ! string to search - - !EOP - - !----- local ----- - integer(SHR_KIND_IN) :: count ! counts occurances of char - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !----- formats ----- - character(*),parameter :: subName = "(shr_string_listGetNum) " - character(*),parameter :: F00 = "('(shr_string_listGetNum) ',4a)" - - !------------------------------------------------------------------------------- - ! Notes: - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - shr_string_listGetNum = 0 - - if (len_trim(str) > 0) then - count = shr_string_countChar(str,listDel) - shr_string_listGetNum = count + 1 - endif - - if (debug>1) call shr_timer_stop (t01) - - end function shr_string_listGetNum - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listSetDel -- Set list delimiter character - ! - ! !DESCRIPTION: - ! Set field delimiter character in lists - ! \newline - ! call shr\_string\_listSetDel(":") - ! - ! !REVISION HISTORY: - ! 2005-Apr-30 - T. Craig - first prototype - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listSetDel(cflag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(len=1),intent(in) :: cflag - - !EOP - - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !--- formats --- - character(*),parameter :: subName = "(shr_string_listSetDel) " - character(*),parameter :: F00 = "('(shr_string_listSetDel) ',a) " - - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) 'changing listDel from '//trim(listDel)//' to '//trim(cflag) - listDel = trim(cflag) - listDel2 = listDel//listDel - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listSetDel - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_listGetDel -- Get list delimiter character - ! - ! !DESCRIPTION: - ! Get field delimiter character in lists - ! \newline - ! call shr\_string\_listGetDel(del) - ! - ! !REVISION HISTORY: - ! 2005-May-15 - T. Craig - first prototype - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_listGetDel(del) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),intent(out) :: del - - !EOP - - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !--- formats --- - character(*),parameter :: subName = "(shr_string_listGetDel) " - character(*),parameter :: F00 = "('(shr_string_listGetDel) ',a) " - - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - del = trim(listDel) - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_listGetDel - - !=============================================================================== - ! - ! shr_string_listFromSuffixes - ! - ! Returns a string of colon delimited fields given an array of suffixes and a base string - ! - ! given suffixes = ['_s1', '_s2', '_s3'] and strBase = 'foo', returns: - ! 'foo_s1:foo_s2:foo_s3' - ! - !=============================================================================== - function shr_string_listFromSuffixes( suffixes, strBase ) result ( retString ) - - character(len=*), intent(in) :: suffixes(:) - character(len=*), intent(in) :: strBase - character(len=:), allocatable :: retString - - integer :: nfields - integer :: i - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - character(len=*), parameter :: subName = "(shr_string_listFromSuffixes) " - - !------------------------------------------------------------------------------- - - if ( debug > 1 .and. t01 < 1 ) call shr_timer_get( t01,subName ) - if ( debug > 1 ) call shr_timer_start( t01 ) - - nfields = size(suffixes) - retString = trim(strBase) // suffixes(1) - do i = 2, nfields - retString = trim(retString) // ':' // trim(strBase) // suffixes(i) - end do - - if ( debug > 1 ) call shr_timer_stop ( t01 ) - - end function shr_string_listFromSuffixes - - !=============================================================================== - ! - ! shr_string_listCreateField - ! - ! Returns a string of colon delimited fields for use in shr_strdata_create - ! arguments, fldListFile and fldListModel. - ! Use to create actual args for shr_strdata_create (fldListFile and - ! flidListModel). - ! - ! This works for numFields up to 999. Modify the string write if you want - ! more range. - ! - ! retString = shr_string_listCreateField(numFields, strBase) - ! given numFields = 5 and strBase = LAI, returns: - ! LAI_1:LAI_2:LAI_3:LAI_4:LAI_5 - ! - !=============================================================================== - function shr_string_listCreateField( numFields, strBase ) result ( retString ) - - implicit none - - integer(SHR_KIND_IN), intent(in) :: numFields ! number of fields - character(len=*) , intent(in) :: strBase ! input string base - character(SHR_KIND_CXX) :: retString ! colon delimited field list - - integer :: idx ! index for looping over numFields - integer(SHR_KIND_IN) :: t01 = 0 ! timer - character(SHR_KIND_CX) :: tmpString ! temporary - character(SHR_KIND_CX) :: intAsChar ! temporary - character(1), parameter :: colonStr = ':' - character(1), parameter :: underStr = '_' - - !--- formats --- - character(*),parameter :: subName = "(shr_string_listCreateField) " - character(*),parameter :: F00 = "('(shr_string_listCreateField) ',a) " - - !------------------------------------------------------------------------------- - - if ( debug > 1 .and. t01 < 1 ) call shr_timer_get( t01,subName ) - if ( debug > 1 ) call shr_timer_start( t01 ) - - ! - ! this assert isn't that accurate since it counts all integers as being one - ! digit, but it should catch most errors and under rather than overestimates - ! -#ifdef DEBUG - call shr_assert((((len(strBase) + 3) * numFields) <= 1024), & - file=__FILE__, line=__LINE__) -#endif - retString = '' - do idx = 1,numFields - - ! reset temps per numField - intAsChar = '' - tmpString = '' - - ! string conversion based on 1,2,3 digits - if ( idx < 10 ) then - write(intAsChar, "(I1)") idx - else if ( idx >= 10 .and. idx < 100 ) then - write(intAsChar, "(I2)") idx - else - write(intAsChar, "(I3)") idx - end if - - tmpString = trim(StrBase)//trim(underStr)//trim(intAsChar) - - if ( idx > 1 ) then - tmpString = trim(colonStr)//trim(tmpString) - end if - - retString = trim(retString)//trim(tmpString) - - end do - - if ( debug > 1 ) call shr_timer_stop ( t01 ) - - end function shr_string_listCreateField - - !=============================================================================== - ! - ! shr_string_listAddSuffix - ! - ! Given an existing list and a suffix, returns a new list with that suffix added to the - ! end of every field in the list. - ! - ! call shr_string_listAddSuffix('a:b:c', '00', new_list) - ! gives new_list = 'a00:b00:c00' - ! - !=============================================================================== - subroutine shr_string_listAddSuffix(list, suffix, new_list) - - implicit none - - character(len=*), intent(in) :: list - character(len=*), intent(in) :: suffix - character(len=*), intent(out) :: new_list - - integer :: num_fields - integer :: field_num - character(SHR_KIND_CS) :: this_field - character(len(this_field) + len(suffix)) :: this_field_with_suffix - character(len(new_list)) :: temp_list - - num_fields = shr_string_listGetNum(list) - new_list = ' ' - - do field_num = 1, num_fields - call shr_string_listGetName(list, field_num, this_field) - this_field_with_suffix = trim(this_field) // suffix - temp_list = new_list - call shr_string_listMerge(temp_list, this_field_with_suffix, new_list) - end do - end subroutine shr_string_listAddSuffix - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_setAbort -- Set local shr_string abort flag - ! - ! !DESCRIPTION: - ! Set local shr_string abort flag, true = abort, false = print and continue - ! \newline - ! call shr\_string\_setAbort(.false.) - ! - ! !REVISION HISTORY: - ! 2005-Apr-30 - T. Craig - first prototype - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_setAbort(flag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - logical,intent(in) :: flag - - !EOP - - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !--- formats --- - character(*),parameter :: subName = "(shr_string_setAbort) " - character(*),parameter :: F00 = "('(shr_string_setAbort) ',a) " - - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - if (debug > 0 .and. s_loglev > 0) then - if (flag) then - write(s_logunit,F00) 'setting abort to true' - else - write(s_logunit,F00) 'setting abort to false' - endif - endif - - doabort = flag - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_setAbort - - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_string_setDebug -- Set local shr_string debug level - ! - ! !DESCRIPTION: - ! Set local shr_string debug level, 0 = production - ! \newline - ! call shr\_string\_setDebug(2) - ! - ! !REVISION HISTORY: - ! 2005-Apr-30 - T. Craig - first prototype - ! - ! !INTERFACE: ------------------------------------------------------------------ - - subroutine shr_string_setDebug(iFlag) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - integer(SHR_KIND_IN),intent(in) :: iFlag ! requested debug level - - !EOP - - !--- local --- - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !--- formats --- - character(*),parameter :: subName = "(shr_string_setDebug) " - character(*),parameter :: F00 = "('(shr_string_setDebug) ',a) " - character(*),parameter :: F01 = "('(shr_string_setDebug) ',a,i3,a,i3) " - - !------------------------------------------------------------------------------- - ! NTOE: write statement can be expensive if called many times. - !------------------------------------------------------------------------------- - - if (iFlag>1 .and. t01<1) call shr_timer_get(t01,subName) - if (iFlag>1) call shr_timer_start(t01) - - ! if (s_loglev > 0) write(s_logunit,F01) 'changing debug level from ',debug,' to ',iflag - debug = iFlag - - if (iFlag>1) call shr_timer_stop (t01) - - end subroutine shr_string_setDebug - - !=============================================================================== - !=============================================================================== - - subroutine shr_string_abort(string) - - implicit none - - ! !INPUT/OUTPUT PARAMETERS: - - character(*),optional,intent(in) :: string - - !EOP - - integer(SHR_KIND_IN) :: t01 = 0 ! timer - - !--- local --- - character(SHR_KIND_CX) :: lstring - character(*),parameter :: subName = "(shr_string_abort)" - character(*),parameter :: F00 = "('(shr_string_abort) ',a)" - - !------------------------------------------------------------------------------- - ! NOTE: - ! - no input or output string should be longer than SHR_KIND_CX - !------------------------------------------------------------------------------- - - if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) - if (debug>1) call shr_timer_start(t01) - - lstring = '' - if (present(string)) lstring = string - - if (doabort) then - call shr_sys_abort(trim(lstring)) - else - write(s_logunit,F00) ' no abort:'//trim(lstring) - endif - - if (debug>1) call shr_timer_stop (t01) - - end subroutine shr_string_abort - - !=============================================================================== - !=============================================================================== - -end module shr_string_mod diff --git a/test/include/spmd_utils.F90 b/test/include/spmd_utils.F90 index 7ba9bb2b..c827ac56 100644 --- a/test/include/spmd_utils.F90 +++ b/test/include/spmd_utils.F90 @@ -1,14 +1,11 @@ module spmd_utils - use mpi, only: MPI_COMM_WORLD - implicit none private - integer, parameter, public :: mpicom = MPI_COMM_WORLD + integer, parameter, public :: masterprocid = 0 integer, parameter, public :: iam = 0 integer, parameter, public :: npes = 1 logical, parameter, public :: masterproc = .true. - integer, parameter, public :: masterprocid = 0 end module spmd_utils diff --git a/test/include/time_manager.F90 b/test/include/time_manager.F90 deleted file mode 100644 index 5e5fdaa6..00000000 --- a/test/include/time_manager.F90 +++ /dev/null @@ -1,312 +0,0 @@ -module time_manager - - ! Provide CAM specific time management. This is a wrapper layer for the ESMF - ! time manager utility. - ! This test version skips any ESMF call - - use shr_string_mod, only: to_upper => shr_string_toUpper - use shr_kind_mod, only: r8 => shr_kind_r8, SHR_KIND_CS - use spmd_utils, only: masterproc - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - - implicit none - private - save - -! Public methods - -public ::& - timemgr_init, &! time manager initialization - advance_timestep, &! increment the clocks current time - get_step_size, &! return step size in seconds - get_nstep, &! return timestep number - get_curr_date, &! return date components at end of current timestep - get_prev_date, &! return date components at beginning of current timestep - get_start_date, &! return components of the start date - get_ref_date, &! return components of the reference date - get_perp_date, &! return components of the perpetual date, and current time of day - get_curr_time, &! return components of elapsed time since reference date at end of current timestep - get_prev_time, &! return components of elapsed time since reference date at beg of current timestep - is_first_step, &! return true on first step of initial run - is_first_restart_step ! return true on first step of restart or branch run - -! Private module data - -integer, parameter :: uninit_int = -999999999 - -integer :: dtime = uninit_int ! timestep in seconds - -character(len=32) :: calendar ! Calendar type -logical :: tm_first_restart_step = .false. ! true for first step of a restart or branch run -logical :: tm_perp_calendar = .false. ! true when using perpetual calendar - -!========================================================================================= -contains -!========================================================================================= - -subroutine timemgr_init( & - dtime_in, calendar_in, start_ymd, start_tod, ref_ymd, & - ref_tod, stop_ymd, stop_tod, curr_ymd, curr_tod, & - perpetual_run, perpetual_ymd, initial_run) - - ! Initialize the time manager. - - ! Arguments - integer, intent(in) :: dtime_in ! Coupling period (sec) - character(len=*), intent(IN) :: calendar_in ! Calendar type - integer, intent(IN) :: start_ymd ! Start date (YYYYMMDD) - integer, intent(IN) :: start_tod ! Start time of day (sec) - integer, intent(IN) :: ref_ymd ! Reference date (YYYYMMDD) - integer, intent(IN) :: ref_tod ! Reference time of day (sec) - integer, intent(IN) :: stop_ymd ! Stop date (YYYYMMDD) - integer, intent(IN) :: stop_tod ! Stop time of day (sec) - integer, intent(IN) :: curr_ymd ! current date (YYYYMMDD) - integer, intent(IN) :: curr_tod ! current time of day (sec) - logical, intent(IN) :: perpetual_run ! If in perpetual mode or not - integer, intent(IN) :: perpetual_ymd ! Perpetual date (YYYYMMDD) - logical, intent(in) :: initial_run ! true => initial (or startup) run - - -end subroutine timemgr_init -!========================================================================================= - -subroutine advance_timestep() - -! Increment the timestep number. - -! Local variables - character(len=*), parameter :: sub = 'advance_timestep' - integer :: rc -!----------------------------------------------------------------------------------------- - - tm_first_restart_step = .false. - -end subroutine advance_timestep -!========================================================================================= - -integer function get_step_size() - -! Return the step size in seconds. - -! Local variables - character(len=*), parameter :: sub = 'get_step_size' - integer :: rc -!----------------------------------------------------------------------------------------- - - rc = 1800 - -end function get_step_size -!========================================================================================= - -integer function get_nstep() - -! Return the timestep number. - -! Local variables - character(len=*), parameter :: sub = 'get_nstep' - integer :: rc -!----------------------------------------------------------------------------------------- - - get_nstep = 1 - -end function get_nstep -!========================================================================================= - -subroutine get_curr_date(yr, mon, day, tod, offset) - -! Return date components valid at end of current timestep with an optional -! offset (positive or negative) in seconds. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative - ! for previous times. - -! Local variables - character(len=*), parameter :: sub = 'get_curr_date' - integer :: rc -!----------------------------------------------------------------------------------------- - - yr = 101 - mon = 1 - day = 1 - tod = 0 - -end subroutine get_curr_date -!========================================================================================= - -subroutine get_perp_date(yr, mon, day, tod, offset) - -! Return time of day valid at end of current timestep and the components -! of the perpetual date (with an optional offset (positive or negative) in seconds. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative - ! for previous times. - -! Local variables - character(len=*), parameter :: sub = 'get_perp_date' - integer :: rc - - yr = 1 - mon = 1 - day = 1 - tod = 0 - -end subroutine get_perp_date -!========================================================================================= - -subroutine get_prev_date(yr, mon, day, tod) - -! Return date components valid at beginning of current timestep. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - yr = 100 - mon = 12 - day = 31 - tod = 84600 - -end subroutine get_prev_date -!========================================================================================= - -subroutine get_start_date(yr, mon, day, tod) - -! Return date components valid at beginning of initial run. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - -! Local variables - character(len=*), parameter :: sub = 'get_start_date' - integer :: rc -!----------------------------------------------------------------------------------------- - - call get_curr_date(yr, mon, day, tod) - -end subroutine get_start_date -!========================================================================================= - -subroutine get_ref_date(yr, mon, day, tod) - -! Return date components of the reference date. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - -! Local variables - character(len=*), parameter :: sub = 'get_ref_date' - integer :: rc -!----------------------------------------------------------------------------------------- - - call get_curr_date(yr, mon, day, tod) - -end subroutine get_ref_date -!========================================================================================= - -subroutine get_curr_time(days, seconds) - -! Return time components valid at end of current timestep. -! Current time is the time interval between the current date and the reference date. - -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval - -! Local variables - character(len=*), parameter :: sub = 'get_curr_time' - integer :: rc - - days = 0 - seconds = 0 - -end subroutine get_curr_time -!========================================================================================= - -subroutine get_prev_time(days, seconds) - -! Return time components valid at beg of current timestep. -! prev time is the time interval between the prev date and the reference date. - -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval - -! Local variables - character(len=*), parameter :: sub = 'get_prev_time' - integer :: rc -!----------------------------------------------------------------------------------------- - - days = 0 - seconds = 0 - -end subroutine get_prev_time - -logical function is_first_step() - -! Return true on first step of initial run only. - -! Local variables - character(len=*), parameter :: sub = 'is_first_step' - integer :: rc -!----------------------------------------------------------------------------------------- - - is_first_step = .true. - -end function is_first_step -!========================================================================================= - -logical function is_first_restart_step() - -! Return true on first step of restart run only. - -!----------------------------------------------------------------------------------------- - - is_first_restart_step = .false. - -end function is_first_restart_step -!========================================================================================= - -logical function is_last_step() - -! Return true on last timestep. - -! Local variables - character(len=*), parameter :: sub = 'is_last_step' - integer :: rc -!----------------------------------------------------------------------------------------- - - is_last_step = .false. - -end function is_last_step - -end module time_manager diff --git a/test/utils_tests/CMakeLists.txt b/test/utils_tests/CMakeLists.txt deleted file mode 100644 index 367e1497..00000000 --- a/test/utils_tests/CMakeLists.txt +++ /dev/null @@ -1,127 +0,0 @@ -CMAKE_MINIMUM_REQUIRED(VERSION 3.11) -PROJECT(TestUtils) -ENABLE_LANGUAGE(Fortran) - -include(CMakeForceCompiler) - -find_package(MPI REQUIRED) -add_definitions(${MPI_Fortran_COMPILE_FLAGS}) -include_directories(${MPI_Fortran_INCLUDE_PATH}) -link_directories(${MPI_Fortran_LIBRARIES}) - -#----------------------------------------------------------------------------- -# -# Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) -# -#----------------------------------------------------------------------------- -GET_FILENAME_COMPONENT(TEST_PATH ${CMAKE_CURRENT_SOURCE_DIR} DIRECTORY) -SET(UTILS_PATH ${TEST_PATH}/include) -GET_FILENAME_COMPONENT(ROOT_PATH ${TEST_PATH} DIRECTORY) -SET(SRC_PATH ${ROOT_PATH}/src) -SET(HIST_PATH ${SRC_PATH}/history) -# Find CIME directory -if (EXISTS "${ROOT_PATH}/cime") - SET(CIME_PATH ${ROOT_PATH}/cime) -else(EXISTS "${ROOT_PATH}/cime") - GET_FILENAME_COMPONENT(_components ${ROOT_PATH} DIRECTORY) - GET_FILENAME_COMPONENT(_toplev ${_components} DIRECTORY) - SET(CIME_PATH ${_toplev}/cime) -endif(EXISTS "${ROOT_PATH}/cime") -# Test copies of CAM and CIME utility files -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_string_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_infnan_mod.F90") -LIST(APPEND SOURCE_FILES "${UTILS_PATH}/shr_assert_mod.F90") -# Regular CAM and CIME utility files -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_kind_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_mpi_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_abort_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_sys_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_timer_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_log_mod.F90") -LIST(APPEND SOURCE_FILES "${CIME_PATH}/src/share/util/shr_strconvert_mod.F90") -LIST(APPEND SOURCE_FILES "${SRC_PATH}/utils/string_utils.F90") -# Utility test modules -LIST(APPEND SOURCE_FILES "${CMAKE_CURRENT_SOURCE_DIR}/string_utils_tests.F90") -# TEST_EXE.F90 is the name of the program source file -SET(TEST_EXE "test_utils") -ADD_EXECUTABLE(${TEST_EXE} ${TEST_EXE}.F90) - -#----------------------------------------------------------------------------- -############################################################################## -# -# End of project-specific input -# -############################################################################## -#----------------------------------------------------------------------------- - -# Use rpaths on MacOSX -set(CMAKE_MACOSX_RPATH 1) - -#----------------------------------------------------------------------------- -# Set a default build type if none was specified -if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) - #message(STATUS "Setting build type to 'Debug' as none was specified.") - #set(CMAKE_BUILD_TYPE Debug CACHE STRING "Choose the type of build." FORCE) - message(STATUS "Setting build type to 'Release' as none was specified.") - set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) - - # Set the possible values of build type for cmake-gui - set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" - "MinSizeRel" "RelWithDebInfo") -endif() - -ADD_COMPILE_OPTIONS(-O0) - -if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") -# gfortran -# MESSAGE("gfortran being used.") - ADD_COMPILE_OPTIONS(-fcheck=all) - ADD_COMPILE_OPTIONS(-fbacktrace) - ADD_COMPILE_OPTIONS(-ffpe-trap=zero) - ADD_COMPILE_OPTIONS(-finit-real=nan) - ADD_COMPILE_OPTIONS(-ggdb) - ADD_COMPILE_OPTIONS(-ffree-line-length-none) - ADD_COMPILE_OPTIONS(-cpp) - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DHAVE_IEEE_ARITHMETIC") -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") -# ifort -# MESSAGE("ifort being used.") - #ADD_COMPILE_OPTIONS(-check all) - ADD_COMPILE_OPTIONS(-fpe0) - ADD_COMPILE_OPTIONS(-warn) - ADD_COMPILE_OPTIONS(-traceback) - ADD_COMPILE_OPTIONS(-debug extended) - ADD_COMPILE_OPTIONS(-fpp) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") -# pgf90 -# MESSAGE("pgf90 being used.") - ADD_COMPILE_OPTIONS(-g) - ADD_COMPILE_OPTIONS(-Mipa=noconst) - ADD_COMPILE_OPTIONS(-traceback) - ADD_COMPILE_OPTIONS(-Mfree) - ADD_COMPILE_OPTIONS(-Mfptrap) - ADD_COMPILE_OPTIONS(-Mpreprocess) -else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - message (FATAL_ERROR "This program has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${CMAKE_SOURCE_DIR}/CMakeLists.txt") -endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") -set (CMAKE_Fortran_FLAGS - "${CMAKE_Fortran_FLAGS} -I${CIME_PATH}/src/share/include") - -#----------------------------------------------------------------------------- -# Set OpenMP flags for C/C++/Fortran -if (OPENMP) - include(detect_openmp) - detect_openmp() - set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} ${OpenMP_C_FLAGS}") - set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${OpenMP_CXX_FLAGS}") - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") - message(STATUS "Enable OpenMP support for C/C++/Fortran compiler") -else(OPENMP) - message (STATUS "Disable OpenMP support for C/C++/Fortran compiler") -endif() -TARGET_SOURCES(${TEST_EXE} PUBLIC ${SOURCE_FILES}) -TARGET_LINK_LIBRARIES(${TEST_EXE} ${MPI_Fortran_LIBRARIES}) - -set_target_properties(${TEST_EXE} PROPERTIES - COMPILE_FLAGS "${CMAKE_Fortran_FLAGS}" - LINK_FLAGS "${CMAKE_Fortran_FLAGS}") diff --git a/test/utils_tests/string_utils_tests.F90 b/test/utils_tests/string_utils_tests.F90 deleted file mode 100644 index 86cf0858..00000000 --- a/test/utils_tests/string_utils_tests.F90 +++ /dev/null @@ -1,88 +0,0 @@ -module string_utils_tests - - use shr_kind_mod, only: max_chars=>SHR_KIND_CX - use shr_kind_mod, only: max_flen=>SHR_KIND_CL - use shr_kind_mod, only: cs=>SHR_KIND_CS - - implicit none - private - - public test_string_utils - -CONTAINS - - subroutine test_string_utils(errcnt, testcnt) - use string_utils, only: parse_multiplier - ! Dummy arguments - integer, intent(out) :: errcnt - integer, intent(out) :: testcnt - ! Local variables - integer :: multiplier - character(len=cs) :: token - character(len=max_flen) :: errmsg - character(len=*), parameter :: subname = 'test_string_utils: ' - - errcnt = 0 - testcnt = 0 - ! Test normal case - call parse_multiplier("9*nstep", multiplier, token, errmsg=errmsg) - testcnt = testcnt + 1 - if ((multiplier /= 9) .or. (trim(token) /= "nstep")) then - write(6, *) subname, trim(errmsg) - errcnt = errcnt + 1 - end if - ! Test default count - call parse_multiplier("nstep", multiplier, token, errmsg=errmsg) - testcnt = testcnt + 1 - if ((multiplier /= 1) .or. (trim(token) /= "nstep")) then - write(6, *) subname, trim(errmsg) - errcnt = errcnt + 1 - end if - ! Test bad multiplier - call parse_multiplier("9a*nstep", multiplier, token, errmsg=errmsg) - testcnt = testcnt + 1 - if ((multiplier /= -1) .or. (len_trim(token) > 0)) then - if (multiplier /= -1) then - write(6, '(2a,i0,a)') subname, "multiplier = ", multiplier, & - ", should be -1" - end if - if (len_trim(token) > 0) then - write(6, *) subname, "token = '", trim(token), "', should be empty" - end if - errcnt = errcnt + 1 - else if (adjustl(trim(errmsg)) /= & - "Invalid multiplier, '9a' in '9a*nstep'") then - write(6, *) subname, "!", trim(errmsg), "!" - errcnt = errcnt + 1 - end if - ! Test empty string - call parse_multiplier("", multiplier, token, errmsg=errmsg) - testcnt = testcnt + 1 - if ((multiplier /= 0) .or. (trim(token) /= "")) then - write(6, *) subname, trim(errmsg) - errcnt = errcnt + 1 - end if - ! Test member of allowed set - call parse_multiplier("9*nstep", multiplier, token, errmsg=errmsg, & - allowed_set = (/ 'nhour ', 'nhours', 'nstep ', 'nsteps' /)) - testcnt = testcnt + 1 - if ((multiplier /= 9) .or. (trim(token) /= "nstep")) then - write(6, *) subname, trim(errmsg) - errcnt = errcnt + 1 - end if - ! Test not member of allowed set - call parse_multiplier("9*step", multiplier, token, errmsg=errmsg, & - allowed_set = (/ 'nhour ', 'nstep ', 'nsteps' /)) - testcnt = testcnt + 1 - if ((multiplier /= -1) .or. (trim(token) /= "")) then - write(6, *) subname, trim(errmsg) - errcnt = errcnt + 1 - else if (adjustl(trim(errmsg)) /= & - "Error, token, 'step' not in (/ 'nhour', 'nstep', 'nsteps' /)") then - write(6, *) subname, "!", trim(errmsg), "!" - errcnt = errcnt + 1 - end if - - end subroutine test_string_utils - -end module string_utils_tests diff --git a/test/utils_tests/test_utils.F90 b/test/utils_tests/test_utils.F90 deleted file mode 100644 index 51a8a8f0..00000000 --- a/test/utils_tests/test_utils.F90 +++ /dev/null @@ -1,30 +0,0 @@ -program test_utils - - - use shr_kind_mod, only: max_chars=>SHR_KIND_CX - use shr_kind_mod, only: max_flen=>SHR_KIND_CL - use string_utils_tests, only: test_string_utils - - implicit none - - integer :: out_unit = 6 - integer :: ierr - integer :: errcnt - integer :: testcnt - integer :: total_errcnt = 0 - integer :: total_tests = 0 - - ! Test string utilities - call test_string_utils(errcnt, testcnt) - total_errcnt = total_errcnt + errcnt - total_tests = total_tests + testcnt - - if (total_errcnt > 0) then - write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' - STOP 1 - else - write(6, '(a,i0,a)') "All ", total_tests, " utility tests passed!" - STOP 0 - end if - -end program test_utils From ae52006750443bf43d98311359bd54c286fe6c3b Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 11 Jun 2024 21:50:59 -0600 Subject: [PATCH 28/79] fix mpi broadcast nl counts --- src/history/cam_hist_file.F90 | 41 +++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 62d4ab20..662ef96e 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1618,7 +1618,11 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & logical :: hist_write_nstep0 ! Local variables (other) integer :: ierr - integer :: num_fields + integer :: num_fields_inst + integer :: num_fields_avg + integer :: num_fields_min + integer :: num_fields_max + integer :: num_fields_var integer :: file_type integer :: rl_kind logical :: has_acc @@ -1692,43 +1696,48 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & call endrun(subname//"ERROR, Invalid precision, '"// & trim(hist_precision)//"'", file=__FILE__, line=__LINE__) end select + num_fields_inst = count_array(hist_inst_fields) + num_fields_avg = count_array(hist_avg_fields) + num_fields_min = count_array(hist_min_fields) + num_fields_max = count_array(hist_max_fields) + num_fields_var = count_array(hist_var_fields) end if + call MPI_Bcast(num_fields_inst, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + call MPI_Bcast(num_fields_avg, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + call MPI_Bcast(num_fields_min, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + call MPI_Bcast(num_fields_max, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + call MPI_Bcast(num_fields_var, 1, MPI_INTEGER, masterprocid, mpicom, ierr) ! Broadcast namelist data - num_fields = count_array(hist_inst_fields) - if (num_fields > 0) then - call MPI_Bcast(hist_inst_fields(:), num_fields, MPI_CHARACTER, & + if (num_fields_inst > 0) then + call MPI_Bcast(hist_inst_fields(:), num_fields_inst, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if - num_fields = count_array(hist_avg_fields) - if (num_fields > 0) then + if (num_fields_avg > 0) then call endrun(subname//"ERROR, average fields not yet implemented", & file=__FILE__, line=__LINE__) has_acc = .true. - call MPI_Bcast(hist_avg_fields(:), num_fields, MPI_CHARACTER, & + call MPI_Bcast(hist_avg_fields(:), num_fields_avg, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if - num_fields = count_array(hist_min_fields) - if (num_fields > 0) then + if (num_fields_min > 0) then call endrun(subname//"ERROR, minimum fields not yet implemented", & file=__FILE__, line=__LINE__) has_acc = .true. - call MPI_Bcast(hist_min_fields(:), num_fields, MPI_CHARACTER, & + call MPI_Bcast(hist_min_fields(:), num_fields_min, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if - num_fields = count_array(hist_max_fields) - if (num_fields > 0) then + if (num_fields_max > 0) then call endrun(subname//"ERROR, maximum fields not yet implemented", & file=__FILE__, line=__LINE__) has_acc = .true. - call MPI_Bcast(hist_max_fields(:), num_fields, MPI_CHARACTER, & + call MPI_Bcast(hist_max_fields(:), num_fields_max, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if - num_fields = count_array(hist_var_fields) - if (num_fields > 0) then + if (num_fields_var > 0) then call endrun(subname//"ERROR, standard deviation fields not yet implemented", & file=__FILE__, line=__LINE__) has_acc = .true. - call MPI_Bcast(hist_var_fields(:), num_fields, MPI_CHARACTER, & + call MPI_Bcast(hist_var_fields(:), num_fields_var, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if call MPI_Bcast(hist_volume, vlen, MPI_CHARACTER, masterprocid, & From 222227a0672b2fad8ecb04114045b79a12b5ec18 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 14 Jun 2024 09:12:24 -0600 Subject: [PATCH 29/79] Updating to latest atmos_phys. --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 90fbed6a..56daa7b4 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = a824aa75db0fcbec8d017ece4cb472ad633982d9 +tag = d0a9dacd5532a50651a26a55781264d094882810 required = True [externals_description] From 138f410e7579d641649ffa9c98990bc21d7fa20c Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 17 Jun 2024 08:13:21 -0600 Subject: [PATCH 30/79] Updating to latest atmos_phys. --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 56daa7b4..2a9b28b4 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -17,7 +17,7 @@ required = True local_path = src/physics/ncar_ccpp protocol = git repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = d0a9dacd5532a50651a26a55781264d094882810 +tag = 4c5b2fe9d7b190c173b71c6a18dae86424a4f610 required = True [externals_description] From c561a98c6743c8e217cb1d36626914ec5e88aed4 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 24 Jun 2024 21:49:35 -0600 Subject: [PATCH 31/79] Updating to latest atmos_phys. --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 2a9b28b4..a55849c2 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -16,8 +16,8 @@ required = True [ncar-physics] local_path = src/physics/ncar_ccpp protocol = git -repo_url = https://github.com/mwaxmonsky/atmospheric_physics -tag = 4c5b2fe9d7b190c173b71c6a18dae86424a4f610 +repo_url = https://github.com/ESCOMP/atmospheric_physics +tag = atmos_phys0_03_000 required = True [externals_description] From 7eddc0118db1dd7ebeb766f2865e68e273ce9c4f Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 24 Jun 2024 22:28:45 -0600 Subject: [PATCH 32/79] fix dimensions for parallel; move history to timestep_final --- src/control/cam_comp.F90 | 37 ++++++++------------------ src/cpl/nuopc/atm_comp_nuopc.F90 | 45 ++++++++++++++++++++++++++++++-- src/history/cam_hist_file.F90 | 9 +++---- 3 files changed, 58 insertions(+), 33 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index ecaa492b..37ad3fa0 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -397,11 +397,8 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & ! file output. ! !----------------------------------------------------------------------- - use cam_history, only: history_write_files - use cam_history, only: history_wrap_up ! use cam_restart, only: cam_write_restart ! use qneg_module, only: qneg_print_summary - use time_manager, only: is_last_step type(cam_out_t), intent(inout) :: cam_out ! Output from CAM to surface type(cam_in_t), intent(inout) :: cam_in ! Input from surface to CAM @@ -412,19 +409,6 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & integer, intent(in), optional :: day_spec ! Simulation day integer, intent(in), optional :: sec_spec ! Secs in current simulation day - !---------------------------------------------------------- - ! History and restart logic: Write and/or dispose history - ! tapes if required - !---------------------------------------------------------- - ! -!!XXgoldyXX: v need to import this -! call t_barrierf('sync_wshist', mpicom) -! call t_startf('wshist') - call physics_history_out() - call history_write_files() -! call t_stopf('wshist') -!!XXgoldyXX: ^ need to import this - ! ! Write restart files ! @@ -444,34 +428,35 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & call t_stopf('cam_write_restart') end if -!!XXgoldyXX: v need to import this -! call t_startf ('cam_run4_wrapup') - call history_wrap_up(rstwr, nlend) -! call t_stopf ('cam_run4_wrapup') -!!XXgoldyXX: ^ need to import this - - call shr_sys_flush(iulog) - end subroutine cam_run4 ! !----------------------------------------------------------------------- ! - subroutine cam_timestep_final() + subroutine cam_timestep_final(rstwr, nlend) !----------------------------------------------------------------------- ! ! Purpose: Timestep final runs at the end of each timestep ! !----------------------------------------------------------------------- - use phys_comp, only: phys_timestep_final + use phys_comp, only: phys_timestep_final + use cam_history, only: history_write_files + use cam_history, only: history_wrap_up + logical, intent(in) :: rstwr ! write restart file + logical, intent(in) :: nlend ! this is final timestep + call physics_history_out() + call history_write_files() + ! peverwhee - todo: handle restarts + call history_wrap_up(rstwr, nlend) ! !---------------------------------------------------------- ! PHYS_TIMESTEP_FINAL Call the Physics package !---------------------------------------------------------- ! call phys_timestep_final() + call shr_sys_flush(iulog) end subroutine cam_timestep_final diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 100259ec..9be94ade 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -1163,7 +1163,7 @@ subroutine ModelAdvance(gcomp, rc) call cam_run4( cam_out, cam_in, rstwr, nlend, & yr_spec=yr_sync, mon_spec=mon_sync, day_spec=day_sync, sec_spec=tod_sync) call t_stopf ('CAM_run4') - call cam_timestep_final() + call cam_timestep_final( rstwr, nlend ) ! Advance cam time step @@ -1388,6 +1388,17 @@ subroutine ModelFinalize(gcomp, rc) ! local variables integer :: shrlogunit ! original log unit + logical :: rstwr, nlend + type(ESMF_Alarm) :: alarm + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime ! Current time + type(ESMF_Time) :: nextTime ! Current time + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + integer :: yr_sync ! Sync current year + integer :: mon_sync ! Sync current month + integer :: day_sync ! Sync current day + integer :: tod_sync ! Sync current time of day (sec) character(*), parameter :: F00 = "('(atm_comp_nuopc) ',8a)" character(*), parameter :: F91 = "('(atm_comp_nuopc) ',73('-'))" character(len=*),parameter :: subname=trim(modName)//':(ModelFinalize) ' @@ -1401,8 +1412,38 @@ subroutine ModelFinalize(gcomp, rc) call shr_log_getLogUnit (shrlogunit) call shr_log_setLogUnit (iulog) + call NUOPC_ModelGet(gcomp, modelClock=clock, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine if time to write restart + call ESMF_ClockGet( clock, currTime=currTime) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime, yy=yr_sync, mm=mon_sync, dd=day_sync, s=tod_sync, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + rstwr = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + rstwr = .false. + endif - call cam_timestep_final() + ! Determine if time to stop + + call ESMF_ClockGetAlarm(clock, alarmname='alarm_stop', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + nlend = .true. + else + nlend = .false. + endif + call cam_timestep_final(rstwr, nlend) call cam_final( cam_out, cam_in ) if (masterproc) then diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 662ef96e..9726c34f 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1273,7 +1273,6 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) use time_manager, only: get_nstep, get_curr_date, get_curr_time use time_manager, only: set_date_from_time_float, get_step_size use datetime_mod, only: datetime - use hist_api, only: hist_buffer_norm_value use spmd_utils, only: masterproc use cam_logfile, only: iulog use perf_mod, only: t_startf, t_stopf @@ -1467,19 +1466,19 @@ subroutine config_write_field(this, field, split_file_index, restart, & !!! Get the field's shape and decomposition ! Shape on disk call field%shape(field_shape) + call field%beg_dims(beg_dims) + call field%end_dims(end_dims) frank = size(field_shape) if (frank == 1) then - allocate(field_data(field_shape(1), 1), stat=ierr) + allocate(field_data(end_dims(1) - beg_dims(1) + 1, 1), stat=ierr) call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) else - allocate(field_data(field_shape(1), field_shape(2)), stat=ierr) + allocate(field_data(end_dims(1) - beg_dims(1) + 1, field_shape(2)), stat=ierr) call check_allocate(ierr, subname, 'field_data', file=__FILE__, line=__LINE__-1) end if ! Shape of array call field%dimensions(dimind) - call field%beg_dims(beg_dims) - call field%end_dims(end_dims) allocate(dim_sizes(size(beg_dims)), stat=ierr) call check_allocate(ierr, subname, 'dim_sizes', file=__FILE__, line=__LINE__-1) do idx = 1, size(beg_dims) From 70c235ce9266c048f298829cb9af6b6e410ce143 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Thu, 27 Jun 2024 14:43:15 -0600 Subject: [PATCH 33/79] Removing standard names csv file as no longer needed. --- src/data/CCPP Standard Names - Sheet1.csv | 684 ---------------------- 1 file changed, 684 deletions(-) delete mode 100644 src/data/CCPP Standard Names - Sheet1.csv diff --git a/src/data/CCPP Standard Names - Sheet1.csv b/src/data/CCPP Standard Names - Sheet1.csv deleted file mode 100644 index dfb085aa..00000000 --- a/src/data/CCPP Standard Names - Sheet1.csv +++ /dev/null @@ -1,684 +0,0 @@ -Snapshot Variable Name,Snapshot Longname,Longname Location,Snapshot Units,Accepted Units,CCPP Standard Name,Accepted,Pushed to ESCOMP,Flag for future work,Flag to skip/deprecate,Notes,Andrew G Description,,, -lat,latitude,snapshot file,degrees north,X,latitude,X,X,,,Jesse,,,, -lon,longitude,snapshot file,degrees east,X,longitude,X,X,,,Cheryl,,,, -gw,latitude weights,snapshot file,1,X,area_weight_wrt_latitude,X,,,X,Courtney,,,, -lev,hybrid level at midpoints,snapshot file,hPa,X,reference_pressure_in_atmosphere_layer,x,X,,,,,,, -hyam,hybrid A coefficient at layer midpoints,snapshot file,1,X,sigma_pressure_hybrid_coordinate_a_coefficient,X,,,,,,,, -hybm,hybrid B coefficient at layer midpoints,snapshot file,1,X,sigma_pressure_hybrid_coordinate_b_coefficient,X,,,,FIX UNITS!,,,, -P0,reference pressure,snapshot file,Pa,X,reference_pressure,X,X,,,,,,, -ilev,hybrid level at interfaces (1000*(A+B)),snapshot file,hPa,X,reference_pressure_in_atmosphere_layer_at_interface,,,,,,,,, -hyai,hybrid A coefficient at layer interfaces,snapshot file,1,X,sigma_pressure_hybrid_coordinate_a_coefficient_at_interface,,,,,,,,, -hybi,hybrid B coefficient at layer interfaces,snapshot file,1,X,sigma_pressure_hybrid_coordinate_b_coefficient_at_interface,,,,,,,,, -trop_cld_lev,troposphere hybrid level at midpoints (1000*(A+B)),snapshot file,hPa,X,,,,only used in PUMAS,X,,,,, -time,time,snapshot file,days since 0001-01-01 00:00:00,,fractional_days_since_model_start,,,,,,,,, -date,current date (YYYYMMDD),snapshot file,,,current_model_date_in_ISO_order,,,year needs to be 0-padded,,,,,, -datesec,current seconds of current date,snapshot file,,,seconds_of_current_model_date,,,,,,,,, -time_bnds,time interval endpoints,snapshot file,,,,,,,X,,,,, -date_written,date time sample written,cam_history_support.F90: line 209,,,,,,,X,,,,, -time_written,time time sample written,cam_history_support.F90: line 210,,,,,,,X,,,,, -ndbase,base day,snapshot file,,,,,,what is using this?,,,,,, -nsbase,seconds of base day,snapshot file,,,,,,what is using this?,,,,,, -nbdate,base date (YYYYMMDD),snapshot file,,,,,,what is using this?,,,,,, -nbsec,seconds of base date,snapshot file,,,,,,what is using this?,,,,,, -mdt,timestep,snapshot file,s,X,timestep_for_physics,,X,,,,,,, -ndcur,current day (from base day),snapshot file,,,,,,what is using this?,,,,,, -nscur,current seconds of current day,snapshot file,,,,,,what is using this?,,,,,, -co2vmr,co2 volume mixing ratio,snapshot file,mol mol-1,,volume_mixing_ratio_of_co2_wrt_dry_air,X,,"Needs to be ""of_co2"" and ""wrt_dry_air""","""wrt_dry_air"" may be redundant, but is clear!",units: check with chemists,,,, -ch4vmr,ch4 volume mixing ratio,snapshot file,,,volume_mixing_ratio_ch4,,,"""",,units: check with chemists,,,, -n2ovmr,n20 volume mixing ratio,snapshot file,,,volume_mixing_ratio_n2o,,,"""",,units: check with chemists,,,, -f11vmr,f11 volume mixing ratio,snapshot file,,,volume_mixing_ratio_cfc11,,,"""",,units: check with chemists,,,, -f12vmr,f12 volume mixing ratio,snapshot file,,,volume_mixing_ratio_cfc12,,,"""",,,,,, -sol_tsi,total solar irradiance,snapshot file,W m-2,X,total_solar_irradiance,,,ask chemist - are we using this?,,,,,, -nstep,current timestep,snapshot file,count,X,current_timestep_number,,,,,,,,, -CAM_IN VARIABLES,,,,,,,,,,,,,, -cam_in_aldif,long wave diffuse albedo,camsrfexch.F90: 91,frac,X,surface_albedo_due_to_near_IR_diffuse,,,,,,,,, -cam_in_aldir,long wave direct albedo,camsrfexch.F90: 90,frac,X,surface_albedo_due_to_near_IR_direct,,,,,,,,, -cam_in_asdif,short wave diffuse albedo,camsrfexch.F90: 93,frac,X,surface_albedo_due_to_UV_and_VIS_diffuse,,,,,,,,, -cam_in_asdir,short wave direct albedo,camsrfexch.F90: 92,frac,X,surface_albedo_due_to_UV_and_VIS_direct,,,,,,,,, -cam_in_cflx,constituent flux (emissions),camsrfexch.F90: 112,kg m-2 s-1,X,surface_upward_ccpp_constituent_fluxes,,,,,,,,, -cam_in_depvel,deposition velocities,camsrfexch.F90: line 119,m s-1,,dry_deposition_velocity,,,Have ACOM check this!,,units: check with chemists,,,, -cam_in_dstflx,dust fluxes,camsrfexch.F90: line 120,kg m-2 s-1,,surface_upward_dust_fluxes,,,Have ACOM check this! Also units!,,units: check with chemists,,,, -cam_in_fv,friction velocity,camsrfexch.F90: line 117,m s-1,X,surface_friction_velocity,X,X,,,,,,, -cam_in_icefrac,sea-ice area fraction,camsrfexch.F90: line 110,frac,X,sea_ice_area_fraction,,,"Need to add rule that ""fraction"" means fraction of atmosphere grid cell",Fraction units?,,,,, -cam_in_landfrac,land area fraction,camsrfexch.F90: line 109,frac,X,land_area_fraction,X,X,,,,,,, -cam_in_lhf,latent heat flux,camsrfexch.F90: line 95,W m-2,X,surface_upward_latent_heat_flux,X,X,,,,,,, -cam_in_lwup,longwave up radiative flux,camsrfexch.F90: line 94,W m-2,X,,,,wait until we finish RRTMGP,,,,,, -cam_in_ocnfrac,ocean area fraction,camsrfexch.F90: line 111,frac,X,ocean_area_fraction,X,,,,,,,, -cam_in_ram1,aerodynamical resistance,camsrfexch.F90: line 116,s m-1,X,,,,Need ACOM to check this,"Also the ""addfld"" units might be wrong",,,,, -cam_in_shf,sensible heat flux,camsrfexch.F90: line 96,W m-2,X,surface_upward_sensible_heat_flux,X,,,,,,,, -cam_in_snowhice,snow depth over ice,camsrfexch.F90: line 105,m,X,lwe_surface_snow_depth_over_ice,X,,,,,,,, -cam_in_snowhland,snow depth (liquid water equivalent) over land,camsrfexch.F90: line 104,m,X,lwe_surface_snow_depth_over_land,X,,,,,,,, -cam_in_sst,sea surface temp,camsrfexch.F90: line 103,K,X,sea_surface_temperature,X,X,,,,,,, -cam_in_ts,merged surface temp,camsrfexch.F90: line 102,K,X,surface_blackbody_temperature (might be same as surface_skin_temperature used by NOAA?),,,"ask NOAA about ""skin"" temperature",,,,,, -cam_in_wsx,surface u-stress,camsrfexch.F90: line 97,N m-2,X,surface_eastward_wind_stress,,,,,Units wrong in camsrfexch.F90,,,, -cam_in_wsy,surface v-stress,camsrfexch.F90: line 98,N m-2,X,surface_northward_wind_stress,,,,,Units wrong in camsrfexch.F90,,,, -CAM_OUT_VARIABLES,,,,,,,,,,,,,, -cam_out_bcphidry,dry deposition of hydrophilic black carbon,camsrfexch.F90: line 66,kg m-2 s-1,,dry_deposition_flux_of_hydrophilic_black_carbon_at_surface,,,,,,,,, -cam_out_bcphiwet,wet deposition of hydrophilic black carbon,camsrfexch.F90: line 65,kg m-2 s-1,,wet_deposition_flux_of_hydrophilic_black_carbon_at_surface,,,,,,,,, -cam_out_bcphodry,dry deposition of hydrophobic black carbon,camsrfexch.F90: line 67,kg m-2 s-1,,dry_deposition_flux_of_hydrophobic_black_carbon_at_surface,,,,,,,,, -cam_out_dstdry1,dry deposition of dust (bin1),camsrfexch.F90: line 72,,,,,,,,,,,, -cam_out_dstdry2,dry deposition of dust (bin2),camsrfexch.F90: line 71,,,,,,,,,,,, -cam_out_dstdry3,dry deposition of dust (bin3),camsrfexch.F90: line 74,,,,,,,,,,,, -cam_out_dstdry4,dry deposition of dust (bin4),camsrfexch.F90: line 73,,,,,,,,,,,, -cam_out_dstwet1,wet deposition of dust (bin1),camsrfexch.F90: line 76,,,,,,,,,,,, -cam_out_dstwet2,wet deposition of dust (bin2),camsrfexch.F90: line 75,,,,,,,,,,,, -cam_out_dstwet3,wet deposition of dust (bin3),camsrfexch.F90: line 78,,,,,,,,,,,, -cam_out_dstwet4,wet deposition of dust (bin4),camsrfexch.F90: line 77,,,,,,,,,,,, -cam_out_netsw,surface solar absorbed flux (shortwave),radiation.F90: line 771,,,,,,,,,,,, -cam_out_ocphidry,dry deposition of hydrophilic organic carbon,camsrfexch.F90: line 69,kg m-2 s-1,,dry_deposition_flux_of_hydrophilic_organic_carbon_at_surface,,,,,,,,, -cam_out_ocphiwest,wet deposition of hydrophilic organic carbon,camsrfexch.F90: line 68,kg m-2 s-1,,wet_deposition_flux_of_hydrophilic_organic_carbon_at_surface,,,,,,,,, -cam_out_ocphodry,dry deposition of hydrophobic organic carbon,camsrfexch.F90: line 70,kg m-2 s-1,,dry_deposition_flux_of_hydrophobic_organic_carbon_at_surface,,,,,,,,, -cam_out_precc,convective precipitation rate,camsrfexch.F90: line 520,m s-1,X,lwe_convective_precipitation_rate_at_surface,X,,,,,,,, -cam_out_precl,stratiform precipitation rate,camsrfexch.F90: line 520,m s-1,X,lwe_large_scale_precipitation_rate_at_surface,X,,,,,,,, -cam_out_precsc,convection snow rate,camsrfexch.F90: line 520,m s-1,X,lwe_convective_snowfall_rate_at_surface,X,,,,,,,, -cam_out_precsl,stratiform snow rate,camsrfexch.F90: line 520,m s-1,X,lwe_large_scale_snowfall_rate_at_surface,X,,,,,,,, -cam_out_soll,direct solar rad on surface (>=0.7),radsw.F90: line 153,W m-2,X,,,,Will find in RRTMGP,,,,,, -cam_out_solld,diffuse solar rad on surface (>=0.7),radsw.F90: line 155,W m-2,X,,,,Will find in RRTMGP,,,,,, -cam_out_sols,direct solar rad on surface (<0.7),radsw.F90: line 152,W m-2,X,,,,Will find in RRTMGP,,,,,, -cam_out_solsd,diffuse solar rad on surface (<0.7),radsw.F90: line 154,W m-2,X,,,,Will find in RRTMGP,,,,,, -CONSTITUENT VARIABLES,,,,,,,,,,,,,, -pcnst,number of constituents,,count,X,,,,number_of_tracers (iap_dom and github),,,,,, -cnst_CLDICE,cloud ice amount,micro_pumas_cam.F90: line 120,kg kg-1,X,cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water,,,"OK name, but not in repo (have wrt_dry_air and interstitial)",,,,,, -cnst_CLIDLIQ,cloud liquid amount,micro_pumas_cam.F90: line 120,kg kg-1,X,cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water,,X,,,,,,, -cnst_DMS,,,kg kg-1,X,,,,,,,,,, -cnst_GRAUQM,graupel amount,micro_pumas_cam.F90: line 120,kg kg-1,X,graupel_water_mixing_ratio_wrt_moist_air,,X,,,,,,, -cnst_H2O2,,,kg kg-1,X,,,,,,,,,, -cnst_H2SO4,,,kg kg-1,X,,,,,,,,,, -cnst_NUMGRA,graupel number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_graupel_wrt_moist_air,X,,,,,,,, -cnst_NUMICE,cloud ice number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_ice_wrt_moist_air,X,,,,,,,, -cnst_NUMLIQ,cloud liquid number,micro_pumas_cam.F90: line 120, kg-1,X,mass_number_concentration_of_cloud_liquid_wrt_moist_air,X,,,,,,,, -cnst_NUMRAI,rain number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_rain_wrt_moist_air,X,,,,,,,, -cnst_NUMSNO,snow number,micro_pumas_cam.F90: line 120,kg-1,X,mass_number_concentration_of_snow_wrt_moist_air,X,,,,,,,, -"cnst_Q and state%q(:,:,1)",water vapor amount,micro_pumas_cam.F90: line 120,kg kg-1,X,water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water,,X,,,,,,, -cnst_RAINQM,rain amount,micro_pumas_cam.F90: line 120,kg kg-1,X,rain_mixing_ratio_wrt_moist_air_and_condensed_water,,-,"drop ""water"" for rain and snow",,,,,, -cnst_SNOWQM,snow amount,micro_pumas_cam.F90: line 120,kg kg-1,X,snow_mixing_ratio_wrt_moist_air_and_condensed_water,,,snow_mixing_ratio_wrt_moist_air in repo,,,,,, -cnst_SO2,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_SOAG,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_bc_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_bc_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_dst_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_dst_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_dst_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_ncl_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_ncl_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_ncl_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_num_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_num_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_num_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_num_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_pom_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_pom_a4,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_so4_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_so4_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_so4_a3,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_soa_a1,,,kg kg-1,,,,,,,units: ask chemists,,,, -cnst_soa_a2,,,kg kg-1,,,,,,,units: ask chemists,,,, -PBUF VARIABLES,,,,,,,,,,,,,, -pbuf_ACCRE_ENHAN,accretion enhancment factor,micro_pumas_cam.F90: line 73,1,X,,,,,SKIP,vestigial - can remove; not in GSL meta file,relative variance?,MG interface meta file: https://github.com/NOAA-GSL/ccpp-physics/blob/gsl/develop/physics/m_micro.meta,, -pbuf_ACGCME,accumulated condensation,micro_pumas_cam.F90: line 740,,,accumulated_condensation_minus_evaporation_due_to_microphysics,,,,,diagnostic; not in GSL meta file,,,, -pbuf_ACNUM,counter for accumulated # timesteps,micro_pumas_cam.F90: line 741,,,counter_for_accumulated_number_of_timesteps_of_nonzero_liquid_water_path,,,,,diagnostic; not in GSL meta file,,,, -pbuf_ACPRECL,accumulated precip,micro_pumas_cam.F90: line 739,,,accumulated_stratiform_precipitation_across_timesteps_with_nonzero_liquid_water_path,,,,,diagnostic; not in GSL meta file,,,, -pbuf_AIST,Ice stratiform cloud fraction,clubb_intr:F90: 1357,frac,,stratiform_cloud_ice_area_fraction,,,,,,,,, -pbuf_ALST,Liquid stratiform cloud fraction,clubb_intr:F90: 1356,frac,,stratiform_cloud_liquid_area_fraction,,,,,,,,, -pbuf_AST,Stratiform cloud fraction,clubb_intr.F90: 1355,frac,,stratiform_cloud_area_fraction,,,,,,,,, -pbuf_BERGSO,Conversion of cloud water to snow from bergeron,micro_pumas_cam.F90: line 977,,,mixing_ratio_wrt_to_moist_air_and_condensed_water_tendency_of_cloud_liquid_water_to_snow_due_to_vapor_deposition,,,,,diagnostic; not in GSL meta file,,,, -pbuf_CC_T,tlat: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2390,,,tendency_of_air_temperature_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_ni,niten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2395,,,tendency_of_cloud_ice_number_concentration_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_nl,nlten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2394,,,tendency_of_cloud_liquid_water_number_concentration_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_qi,qiten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2392,,,tendency_of_cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_ql,qcten: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2393,,,tendency_of_cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_qlst,"qcten/max(0.01_r8,alst_mic(:ncol,top_lev:pver)): Microphysical tendencies for use in the macrophysics at the next time step",micro_pumas_cam.F90: line 2396,,,tendency_of_incloud_cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CC_qv,qvlat: Microphysical tendencies for use in the macrophysics at the next time step,micro_pumas_cam.F90: line 2391,,,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_microphysics,,,,,MG tendency; not in GSL meta file,,,, -pbuf_CFC11,,,,,,,,,,units: ask chemists,,,, -pbuf_CFC12,,,,,,,,,,units: ask chemists,,,, -pbuf_CH4,,,,,,,,,,units: ask chemists,,,, -pbuf_CLD,Total cloud fraction,micro_pumas_cam.F90: line 1604,frac,X,cloud_area_fraction,X,!,"""in_atmosphere_layer"" is implied - should be changed to ""cloud_area_fraction""",,,,,, -pbuf_CLDBOT,Vertical index of cloud base,convect_diagnostics.F90: line 85,index,X,vertical_index_at_cloud_base_for_all_convection,X,,,,,,,, -pbuf_CLDFGRAU,Cloud fraction for liquid+graupel,micro_pumas_cam.F90: line 1611,frac,X,liquid_plus_graupel_stratiform_cloud_area_fraction,X,,,,,,,, -pbuf_CLDFSNOW,Cloud fraction for liquid+snow,micro_pumas_cam.F90: line 1608,frac,X,liquid_plus_snow_stratiform_cloud_area_fraction,X,,,,,,,, -pbuf_CLDICEINI,"state%q(:ncol,:pver,ixcldice) from cnst_get_index('CLDICE')",physpkg.F90: line 2617,kg kg-1,X,cloud_ice_mixing_ratio_wrt_moist_air_before_physics,X,,,,,,,, -pbuf_CLDLIQINI,"state%q(:ncol,:pver,ixcldliq) from cnst_get_index('CLDLIQ')",physpkg.F90: line 2616,kg kg-1,X,cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water_before_physics,X,,,,,,,, -pbuf_CLDO, Old cloud fraction,micro_pumas_cam.F90: line 1463,frac,X,cloud_area_fraction_on_previous_timestep,X,,,,,,,, -pbuf_CLDTOP,Vertical index of cloud top,convect_diagnostics: line 84,index,X,vertical_index_at_cloud_top_for_all_convection,X,,,,,,,, -pbuf_CLOUD_FRAC, Cloud fraction (thermodynamic levels),clubb_intr.F90: line 2175,frac,X,stratiform_cloud_area_fraction_due_to_clubb,X,,,,,,,, -pbuf_CMELIQ,Rate of cond-evap of liq within the cloud,clubb_intr.F90: line 1623,kg kg-1 s-1,X,stratiform_cloud_condensation_minus_evaporation,X,,,,,,,, -pbuf_CMFMC_DP,Convection mass flux from ZM deep,zm_conv_intr.F90: line 301,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_deep_convection,X,,,,,,,, -pbuf_CMFMC_SH,Shallow convective mass flux,macrop_driver.F90: line 481,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_shallow_convection,X,,,,,,,, -pbuf_CO2,,,,,,,,,,units: ask chemists,,,, -pbuf_CONCLD,Convective cloud cover,clubb_intr.F90: line 1622,frac,X,convective_cloud_area_fraction,X,X,,,,,,, -pbuf_CV_REFFICE,convective cloud ice effective radius,cam_dev/micro_pumas_cam.F90: line 1127,micron,,,,,,,cosp thing; not in GSL meta file,,,, -pbuf_CV_REFFLIQ,convective cloud liq effective radius,cam_dev/micro_pumas_cam.F90: line 1126,micron,,,,,,,cosp thing; not in GSL meta file,,,, -pbuf_DEGRAU, Graupel effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 658,m,X,effective_diameter_of_stratiform_cloud_graupel_particle_for_radiation,,,,,from m_micro.meta: cldeffg [radius],,,, -pbuf_DEI, Mitchell ice effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 638,micron,X,effective_diameter_of_stratiform_cloud_ice_particle_for_radiation,,,,,from m_micro.meta: cldeffi [radius],,,, -pbuf_DES,Snow effective diameter for radiation,cam_dev/micro_pumas_cam.F90: line 650,micron,X,effective_diameter_of_stratiform_snow_particle _for_radiation,,,,,from m_micro.meta: cldeffs [radius],,,, -pbuf_DGNUM,"unactivated particles, dry",modal_aero_data.F90: line 777,,,,,,,,ask chemists,,,, -pbuf_DGNUMWET,"unactivated particles, wet at grid-cell ambient RH",modal_aero_data.F90: line 779,,,,,,,,ask chemists,,,, -pbuf_DIFZM,Detrained ice water from ZM convection,zm_conv_intr.F90: line 327,kg kg-1 s-1,X,detrainment_of_cloud_ice_due_to_deep_convection,X,,,,,,,, -pbuf_DLFZM,Detrained liquid water from ZM convection,zm_conv_intr.F90: line 328,kg kg-1 s-1,X,detrainment_of_cloud_liquid_due_to_deep_convection,X,,,,,,,, -pbuf_DP_CLDICE, deep gmb cloud ice water,cosp_simulator_intr.F90: line 1432,kg kg-1,X,,,,,,,,,, -pbuf_DP_CLDLIQ,deep gbm cloud liquid water,cosp_simulator_intr.F90: line 1431,kg kg-1,X,,,,,,,,,, -pbuf_DP_FLXPRC,deep interface gbm flux_convective_cloud_rain+snow,cosp_simulator_intr.F90: line 1415,kg m-2 s-1,X,precipitation_mass_flux_at_interface_due_to_deep_convection,X,,"ask NOAA about precipitation = ""all phases of precipitation""",,,,,, -pbuf_DP_FLXSNW,deep interface gbm flux_convective_cloud_snow,cosp_simulator_intr.F90: line1414,kg m-2 s-1,X,frozen_precipitation_mass_flux_at_interface_due_to_deep_convection,X,,,,,,,, -pbuf_DP_FRAC,Deep convective cloud fraction,conv_water.F90: line 219,frac,X,cloud_area_fraction_due_to_deep_convection,X,,,,,,,, -pbuf_DQCORE,Water vapor tendency due to dynamical core,check_energy.F90: line 207,kg kg-1 s-1,X,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_dynamics,X,,CCPP may need to handle varying standard names dependent on host model configuration (i.e. dycore),,,,,, -pbuf_DRYMASS,single-particle-mean dry mass,modal_aero_calcsize: line 1421,kg,,,,,,,ask chemists,,,, -pbuf_DRYRAD,dry volume mean radius of aerosol,modal_aero_calcsize: line 1420,m,,,,,,,ask chemists,,,, -pbuf_DRYVOL, single-particle-mean dry volume,modal_aero_calcsize: line 1419,m3,,,,,,,ask chemists,,,, -pbuf_DTCORE,T tendency due to dynamical core,check_energy.F90: line 206,K s-1,X,tendency_of_air_temperature_due_to_dynamics,X,,,,,,,, -pbuf_DUCORE,,check_energy.F90,m s-2,X,tendency_of_eastward_wind_due_to_dynamics,X,,,,,,,, -pbuf_DVCORE,,check_energy.F90,m s-2,X,tendency_of_northward_wind_due_to_dynamics,X,,,,,,,, -pbuf_FICE,Fractional ice content within cloud,cam_dev/micro_pumas_cam.F90: line 965,frac,X,mass_fraction_of_ice_content_within_stratiform_cloud,,,,,not in GSL file; qlcn_i is convective version,,,, -pbuf_FLNS,Clearsky net longwave flux at surface,rrtmg/radiation.F90 : line 581,W m-2,X,,,,,,,,,, -pbuf_FLNT,Net longwave flux at top of model,rrtmg/radiation.F90 : line 560,W m-2,X,,,,,,,,,, -pbuf_FRACIS,fraction of transported species that are insoluble,modal_aero/aero_model.F90: line 1066,frac,,fraction_of_water_insoluble_convectively_transported_species,X,,,,ask chemists,,,, -pbuf_FRZCNT,Number tendency due to contact freezing,pumas/micro_pumas_v1.F90:line 781,cm-3,,ice_number_concentration_tendency_due_to_contact_freezing,,,,,not in GSL file,ask andrew about units and whether tendency,,, -pbuf_FRZDEP,Number tendency due to deposition nucleation,pumas/micro_pumas_v1.F90:line 782,cm-3,,ice_number_concentration_tendency_due_to_deposition_nucleation,,,,,not in GSL file,ask andrew about units and whether tendency,,, -pbuf_FRZIMM,Number tendency due to immersion freezing,pumas/micro{pumas_v1.F90: line 780,cm-3,,ice_number_concentration_tendency_due_to_immersion_freezing,,,,,not in GSL file,ask andrew about units and whether tendency,,, -pbuf_FSDS,Downwelling solar flux at surface,rrtmg/radiation.F90: line 516,W m-2,X,,,,,,,,,, -pbuf_FSNS,Net solar flux at surface,rrtmg/radiaton.F90: line 511,W m-2,X,,,,,,,,,, -pbuf_FSNT,Net solar flux at top of model,rrtmg/radiation.F90: line 476,W m-2,X,,,,,,,,,, -pbuf_HYGRO, volume-weighted mean hygroscopicity,chemistry/utils/modal_aero_calcsize.F90,unitless?????,,,,,,,units: ask chemists,,,, -pbuf_ICGRAUWP,In-cloud snow water path,cam_dev/micro_pumas_cam.F90: line 1625,kg m-2,X,stratiform_in_cloud_graupel_water_path,,,Snapshot name is wrong,,not in GSL file,,,, -pbuf_ICIWP,radiation input: In-cloud ice water path,radiation_data.F90: line 363,kg m-2,X,,,,,,,,,, -pbuf_ICIWPST,Stratiform only in cloud ice water path for radiation,cam_dev/micro_pumas.F90: line 645,kg m-2,X,stratiform_in_cloud_ice_water_path_for_radiation,,,,,not in GSL file,,,, -pbuf_ICLWP, In cloud liquid water path for radiation,cloud_diagnostics.F90: line 80,kg m-2,X,,,,,,,,,, -pbuf_ICLWPST,Stratiform in cloud liquid water path for radiation,cam_dev/micro_pumas.F90: line 647,kg m-2,X,stratiform_in_cloud_liquid_water_path_for_radiation,,,,,not in GSL file,,,, -pbuf_ICSWP,radiation input: In-cloud snow water path,radiation_data.F90: line 367,kg m-2,X,,,,,,,,,, -pbuf_ICWMRDP,Deep Convection in-cloud water mixing ratio,convect_deep.F90: line 165,kg kg-1,X,in_cloud_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_deep_convection,X,,,,,,,, -pbuf_ICWMRSH,Shallow Convection in-cloud water mixing ratio,convect_shallow.F90: line 231,kg kg-1,X,in_cloud_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_due_to_shallow_convection,,,,,,,,, -pbuf_ISS_FRAC,Cloud fraction of ice clouds,clubb_intr.F90: line 2210,frac,X,ice_supersaturated_cloud_area_fraction,,,,,,,,, -pbuf_LAMBDAC,radiation input: slope of droplet distribution for optics (radiation),radiation_data.F90: line 361,1,X,,,,,,,,,, -pbuf_LANDM,,cam_dev/physpkg.F90,frac,X,smoothed_land_fraction,,,,,,,,, -pbuf_LS_FLXPRC,MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces,micro_pumas_cam.F90: line 1554,kg m-2 s-1,X, stratiform_rain_and_snow_flux_at_interface,,,,,,,,, -pbuf_LS_FLXSNW,MG grid-box mean flux_large_scale_cloud_snow at interfaces,micro_pumas_cam.F90: line 1555,kg m-2 s-1,X,stratiform_snow_flux_at_interface,,,,,,,,, -pbuf_LS_MRPRC,MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces,micro_pumas_cam.F90: line 1556,kg kg-1,X,stratiform_mixing_ratio_of_snow_wrt_moist_air_and_condensed_water_at_interface,,,,,,,,, -pbuf_LS_MRSNW,MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces,micro_pumas_cam.F90: line 1557,kg kg-1,X,stratiform_mixing_ratio_of_rain_and_snow_wrt_moist_air_and_condensed_water_at_interface,,,,,,,,, -pbuf_LS_REFFRAIN,MG diagnostic rain effective radius (um),micro_pumas_cam.F90: line 1558,micron,X,diagnostic_rain_effective_radius_due_to_microphysics,,,,,,,,, -pbuf_LS_REFFSNOW,MG diagnostic snow effective radius (um),micro_pumas_cam.F90: line 1559,micron,X,diagnostic_snow_effective_radius_due_to_microphysics,,,,,,,,, -pbuf_MU,Size distribution shape parameter for radiation,micro_pumas_cam.F90: line 1470,1,X,size_distribution_shape_parameter_for_microphysics,,,,,,,,, -pbuf_N2O,,pbuf_get_field call in rad_constituents.F90: line 487,,,,,,,,,,,, -pbuf_NAAI,ice nucleation number,micro_pumas_cam.F90: line 1443,kg-1,CONTINUE UNITS HERE!!!!!!!,number_of_activated_ice_nuclei,,,,,,,,, -pbuf_NAAI_HOM,ice nucleation number (homogeneous),micro_pumas_cam.F90: line 1444,kg-1,,number_of_activated_ice_nuclei_due_to_homogenous_freezing,,,,,,,,, -pbuf_NACON,"number in each dust bin, for contact freezing (from microp_aero_ts)",micro_pumas_v1.F90: line 695,m-3,,dust_number_concetnration_by_size_bin_for_contact_freezing,,,,,,,,, -pbuf_NAER, aerosol number MR (bounded!),model_aero_calcsize.F90: line 1423,kg-air-1?,,,,,,,,,,, -pbuf_NEVAPR,Evaporation of total precipitation (rain + snow),micro_pumas_cam.F90: line 1464,,,precipitation_evaporation_due_to_microphysics,,,,,,,,, -pbuf_NEVAPR_DPCU,Evaporation of deep convective precipitation,convect_deep.F90: line 459,,,precipitation_evaporation_due_to_deep_convection,,,,,,,,, -pbuf_NEVAPR_SHCU,Evaporation of shallow convective precipitation >= 0,convect_shallow.F90: line 460,,,precipitation_evaporation_due_to_shallow_convection,,,,,,,,, -pbuf_NPCCN,liquid activation number tendency,micro_pumas_cam.F90: line 1445,,,liquid_drop_activation_number_tendecy,,,,,,,,, -pbuf_O2,,pbuf_get_field call in rad_constituents.F90: line 487,,,,,,,,,,,, -pbuf_PRAIN,Total precipitation (rain + snow),micro_pumas_cam.F90: line 1468,,,precipitation_due_to_microphysics,,,,,,,,, -pbuf_PREC_DP,total precipitation,convect_deep.F90: line 198,m s-1,X,lwe_precipitation_rate_at_surface_due_to_deep_convection,X,,convective_precipitation_rate(iap_dom),,,,,, -pbuf_PREC_PCW,Sfc flux of precip from microphysics,micro_pumas_cam.F90: line 1456,m s-1,,lwe_stratiform_precipitation_rate_at_surface,,,,,,,,, -pbuf_PREC_SED,Surface flux of total cloud water from sedimentation,micro_pumas_cam.F90: line 1454,,,stratiform_cloud_water_surface_flux_due_to_sedimentation,,,,,,,,, -pbuf_PREC_SH,Shallow convective precipitation (rain+snow) rate at surface,convect_shallow.F90: line 407,,,,,,,,,,,, -pbuf_PREC_STR,[Total] Sfc flux of precip from stratiform,micro_pumas_cam.F90: line 1452,m s-1,,stratiform_rain_and_snow_surface_flux_due_to_sedimentation,,,,,,,,, -pbuf_PRER_EVAP,precipitation evaporation rate,micro_pumas_cam.F90: line 1465,,,precipitation_evaporation_rate_due_to_microphysics,,,,,,,,, -pbuf_PSL,sea level pressure,cam_diagnostics.F90: line 967,Pa,,,,,,,,,,, -pbuf_QAERWAT,aerosol water,modal_aer_opt.F90: line 500,g g-1,,,,,,,,,,, -pbuf_QINI,,addfld call in cam/physpkg.F90: line 207,,,,,,,,,,,, -pbuf_QIST,Physical in-stratus IWC,clubb_intr.F90: line 2336,kg kg-1,,stratiform_cloud_ice_water_content,X,,,,,,,, -pbuf_QLST,Physical in-stratus LWC,clubb_intr.F90: line 2335,kg kg-1,,stratiform_cloud_liquid_water_content,X,,,,,,,, -pbuf_QME,Net micro_pumas_cam condensation rate,micro_pumas_cam.F90: line 2399,,,net_condensation_rate_due_to_microphysics,,,,,,,,, -pbuf_QRL,longwave radiative heating rate,rrtmg/radiation.F90: line 794,K s-1,,,,,,,,,,, -pbuf_QRS,shortwave radiative heating rate,rrtmg/radiation.F90: line 793,K s-1,,,,,,,,,,, -pbuf_QSATFAC,Subgrid cloud water saturation scaling factor,micro_pumas_cam.F90: line 1460,,,subgrid_cloud_water_saturation_scaling_factor_for_microphysics,,,,,,,,, -pbuf_RAD_CLUBB,,addfld call in cam/clubb_intr.F90: line 514,,,,,,,,,,,, -pbuf_RATE1_CW2PR_ST,1st order rate for direct conversion of strat. cloud water to precip,micro_pumas_cam.F90: line 1569,s-1,,direct_conversion_rate_of_stratiform_cloud_water_to_precipitation_for_scavenging,,,,,,,,, -pbuf_RCM,CLUBB cloud water mixing ratio ,clubb_intr.F90: line 2326,kg kg-1,,cloud_water_mixing_ratio_wrt_dry_air_due_to_clubb,X,,,,,,,, -pbuf_RC_COEF,Coef. of X'r_c' in Eq. (34) (thermodynamic levels),clubb_intr.F90: line 2318,,,factor_converting_from_liquid_cloud_water_moment_to_component_of_virtual_potential_temperature_moment,X,,,,,,,, -pbuf_REI,Ice effective drop size,micro_pumas_cam.F90: line 1597,micron,,effective_radius_of_stratiform_cloud_ice_particle,X,X,,,from m_micro.meta file: cldreffi,,,, -pbuf_REL,Liquid effective drop radius,micro_pumas_cam.F90: line 1596,micron,,effective_radius_of_stratiform_cloud_liquid_water_particle,X,X,,,from m_micro.meta file: cldreffl,,,, -pbuf_RELVAR,relative variance of cloud water,micro_pumas_cam.F90: line 1417,,,relative_variance_of_subgrid_cloud_condensate_distribution,X,X,,,from m_micro.meta file: mg_qcvar,,,, -pbuf_RLIQBC,tphysbc reserve liquid,cam_dev/physpkg.F90: line 2495,,,,,,,,,,,, -pbuf_RNDST,radius of 4 dust bins for contact freezing,microp_aero.F90: line 490,,,,,,,,,,,, -pbuf_RPRDDP,dq/dt due to deep convective rainout,convect_shallow.F90: line 458,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection_excluding_subcloud_evaporation,X,,,,,,,, -pbuf_RPRDSH,dq/dt due to deep and shallow convective rainout,convect_shallow.F90: line 459,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_shallow_convection_excluding_subcloud_evaporation,X,,,,,,,, -pbuf_RPRDTOT,RPRDDP + RPRDSH,convect_shallow.F90: line 719,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_convection_excluding_subcloud_evaporation,X,,,,,,,, -pbuf_RTM,mean moisture mixing ratio,clubb_intr.F90: line 2325,,,sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_RTP2_nadv,moisture variance,clubb_intr.F90: line 2294,kg2 kg-2,,advected_variance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_RTP3,moisture 3rd order,clubb_intr.F90: line 2396,kg3 kg-3,,third_moment_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_RTPTHLP_nadv,covariance of thetal and qt,clubb_intr.F90: line 2297,kg kg-1 K-1,,covariance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_liquid_water_potential_temperature,X,,,,,,,, -pbuf_RTPTHVP,r_t'th_v' (momentum levels),clubb_intr.F90: line 2327,kg kg-1 K-1,,covariance_of_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_virtual_potential_temperature,X,,,,,,,, -pbuf_SADICE,Ice surface area density,micro_pumas_cam.F90: line 1598,cm2 cm-3,,ice_surface_area_density_for_microphysics,,,,,,,,, -pbuf_SADSNOW,Snow surface area density,micro_pumas_cam.F90: line 1599,cm2 cm-3,,snow_surface_area_density_for_microphysics,,,,,,,,, -pbuf_SGH,standard deviation of orography,gw_drag.F90: line 1330,m,,,,,,,,,,, -pbuf_SGH30,standard deviation of subgrid topographic height at 30 s horizontal area,unicon.F90: line 565,m,,,,,,,,,,, -pbuf_SH_CLDICE1,shallow convection gbx ice cld mixing ratio for COSP,conv_water.F90: line 226,,,,,,,,,,,, -pbuf_SH_CLDLIQ1,shallow convection gbx liq cld mixing ratio for COSP,conv_water.F90: line 225,,,,,,,,,,,, -pbuf_SH_FRAC,shallow convection cloud fraction,conv_water.F90: line 218,,,,,,,,,,,, -pbuf_SNOW_DP,snow from ZM convection,convect_deep.F90: line 206,m s-1,,lwe_frozen_precipitation_rate_at_surface_due_to_deep_convection,X,,"lwe_convective_snowfall_rate (iap_dom), lwe_snowfall_rate (git repo)",,,,,, -pbuf_SNOW_PCW,Sfc flux of snow from microphysics,micro_pumas_cam.F90: line 1408,m s-1,,lwe_snow_precipitation_rate_at_surface_due_to_microphysics,,,,,,,,, -pbuf_SNOW_SED,Surface flux of cloud ice from sedimentation,micro_pumas_cam.F90: line 1406,,,lwe_cloud_ice_sedimentation_rate_at_surface_due_to_microphysics,,,,,,,,, -pbuf_SNOW_SH,shallow convective snow rate at surface,convect_shallow.F90: line 408,m s-1,,,,,,,,,,, -pbuf_SNOW_STR,[Total] Sfc flux of snow from stratiform,micro_pumas_cam.F90: line 1404,m s-1,,lwe_snow_and_cloud_ice_precipitation_rate_at_surface_due_to_microphysics ,,,,,,,,, -pbuf_SO4DRYVOL,single-particle-mean so4 dry volume,modal_aero_calcsize.F90: line 1431,m3,,,,,,,,,,, -pbuf_SRFOZONE,surface ozone,chemistry.F90: line 817,,,,,,,,,,,, -pbuf_TEOUT,total energy for global fixer in next timestep,physpkg.F90: line 1856,J m-2,,,,,,,,,,, -pbuf_THLM,mean temperature,clubb_intr.F90: line 2324,K,,liquid_water_potential_temperature,X,,,,,,,, -pbuf_THLP2_nadv,temperature variance,clubb_intr.F90: line 2295,K2,,advected_variance_of_liquid_water_potential_temperature,X,,,,,,,, -pbuf_THLP3,temperature third order,clubb_intr.F90: line 2297,K3,,third_moment_of_liquid_water_potential_temperature,X,,,,,,,, -pbuf_THLPTHVP,th_l'th_v' (momentum levels),clubb_intr.F90: line 2307,K2,,covariance_of_liquid_water_potential_temperature_and_virtual_potential_temperature,X,,,,,,,, -pbuf_TREFMNAV,daily minimum reference temperature,cam_diagnostics.F90: line 1815,K,,,,,,,,,,, -pbuf_TREFMXAV,daily maximum reference temperature,cam_diagnostics.F90: line 1816,K,,,,,,,,,,, -pbuf_T_TTEND,temperature from previous timestep?,addfld call in cam_diagnostics: line 154,,,,,,,,,,,, -pbuff_T_UTEND,u wind from previous timestep?,addfld call in cam_diagnostics: line 155,,,,,,,,,,,, -pbuf_T_VTEND,v wind from previous timestep?,addfld call in cam_diagnostics: line 156,,,,,,,,,,,, -pbuf_UM,mean east-west wind,clubb_intr.F90: line 2328,m s-1,,eastward_wind,X,,,,,,,, -pbuf_UP2_nadv,east-west wind variance,clubb_intr.F90: line 2298,m2 s-2,,advected_variance_of_eastward_wind,X,,,,,,,, -pbuf_UP3,east-west wind 3rd order,clubb_intr.F90: line 2300,m3 s-3,,third_moment_of_eastward_wind,X,,,,,,,, -pbuf_UPRCP,< u' r_c' > (momentum levels),clubb_intr.F90: line 2316,,,covariance_of_eastward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_UPWP,east-west momentum flux,clubb_intr.F90: line 2302,m2 s-2,,covariance_of_eastward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air_and_vertical_velocity,X,,,,,,,, -pbuf_VM,mean north-south wind,clubb_intr.F90: line 2329,m s-1,,northward_wind,X,,,,,,,, -pbuf_VOLC_MMR1,prescribed volcanic aerosol dry mass mixing ratio in Mode 1,prescribed_strataero.F90: line 272,kg kg-1,,,,,,,,,,, -pbuf_VOLC_MMR2,prescribed volcanic aerosol dry mass mixing ratio in Mode 2,prescribed_strataero.F90: line 273,kg kg-1,,,,,,,,,,, -pbuf_VOLC_MM3,prescribed volcanic aerosol dry mass mixing ratio in Mode 3,prescribed_strataero.F90: line 274,kg kg-1,,,,,,,,,,, -pbuf_VOLC_RAD_GEOM1,volcanic aerosol geometric-mode radius in Mode 1,prescribed_strataero.F90: line 275,m,,,,,,,,,,, -pbuf_VOLC_RAD_GEOM2,volcanic aerosol geometric-mode radius in Mode 2,prescribed_strataero.F90: line 276,m,,,,,,,,,,, -pbuf_VOLC_RAD_GEOM3,volcanic aerosol geometric-mode radius in Mode 3,prescribed_strataero.F90: line 277,m,,,,,,,,,,, -pbuf_VOLC_SAD,stratospheric aerosol surface area density,prescribed_strataero.F90: line 291,cm2 cm-3,,,,,,,,,,, -pbuf_VP2_nadv,north-sound wind variance,clubb_intr.F90: line 2299,m2 s-2,,advected_variance_of_northward_wind,,,,,,,,, -pbuf_VP3,north-south wind 3rd order,clubb_intr.F90: line 2301,m3 s-3,,third_order_moment_of_northward_wind,,,,,,,,, -pbuf_VPRCP,< v' r_c' > (momentum levels),clubb_intr.F90: line 2317,,,covariance_of_northward_wind_and_cloud_liquid_mixing_ratio_wrt_dry_air,,,,,,,,, -pbuf_VPWP,north-south momentum flux,clubb_intr.F90: line 2303,m2 s-2,,covariance_of_northward_wind_and_vertical_velocity,,,,,,,,, -pbuf_WETDENS_AP,,modal_aero_wateruptake.F90: line 41,,,,,,,,,,,, -pbuf_WP2RTP,w'^2 th_v' (thermodynamic levels),clubb_intr.F90: line 2314,,,third_order_moment_of_variance_of_vertical_velocity_and_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_WP2THLP,w'^2 thl' (thermodynamic levels),clubb_intr.F90: line 2315,,,third_order_moment_of_variance_of_vertical_velocity_and_liquid_water_potential_temperature,X,,,,,,,, -pbuf_WP2THVP,second order buoyancy term,clubb_intr.F90: line 2305,m2 s-2 K,,third_order_moment_of_variance_of_vertical_velocity_and_virtual_potential_temperature,X,,,,,,,, -pbuf_WP2UP2,w'^2 u'^2 (momentum levels),clubb_intr.F90: 2322,,,fourth_order_moment_of_variance_of_vertical_velocity_and_variance_of_eastward_wind,X,,,,,,,, -pbuf_WP2VP2,w'^2 v'^2 (momentum levels),clubb_intr.F90: 2323,,,fourth_order_moment_of_variance_of_vertical_velocity_and_variance_of_northward_wind,X,,,,,,,, -pbuf_WP2_nadv,vertical velocity variance,clubb_intr.F90: 2283,m2 s-2,,advected_variance_of_vertical_velocity,X,,,,,,,, -pbuf_WP3_nadv,third moment of vertical velocity,clubb_intr.F90: 2284,m3 s-3,,advected_third_order_moment_of_vertical_velocity,X,,,,,,,, -pbuf_WP4,w'^4 (momentum levels),clubb_intr.F90: line 2319,,,fourth_order_moment_of_vertical_velocity,X,,,,,,,, -pbuf_WPRTP_nadv,turbulent flux of moisture,clubb_intr.F90: line 2292,m s-1 kg kg-1,,advected_covariance_of_vertical_velocity_and_sum_of_water_vapor_and_cloud_liquid_mixing_ratio_wrt_dry_air,X,,,,,,,, -pbuf_WPTHLP_nadv,turbulent flux of thetal,clubb_intr.F90: line 2291,m s-1 K,,advected_covariance_of_vertical_velocity_and_liquid_water_potential_temperature,X,,,,,,,, -pbuf_WPTHVP,Buoyancy Flux,clubb_intr.F90: line 1686,W m-2,,advected_covariance_of_vertical_velocity_and_virtual_potential_temperature,X,,,,,,,, -pbuf_WPUP2,w'u'^2 (thermodynamic levels),clubb_intr.F90: line 2320,,,third_order_moment_of_vertical_velocity_and_variance_of_eastward_wind,X,,,,,,,, -pbuf_WPVP2,w'v^2 (thermodynamic levels),clubb_intr.F90: line 2321,,,third_order_moment_of_vertical_velocity_and_variance_of_northward_wind,X,,,,,,,, -pbuf_WSEDL,Sedimentation velocity of liquid stratus cloud droplet,micro_pumas_cam.F90: line 1571,m s-1,,,,,,,,,,, -pbuf_ZM_DP,Delta pressure between interfaces,modal_aero_convproc.F90: line 556,,hPa,pressure_thickness_for_deep_convection_for_convective_columns,X,,"pressure_thickness_in_hPa (iap_dom) , air_pressure_thickness (in github repo)",X,,,,, -pbuf_ZM_DSUBCLD,Delta pressure from cloud base to sfc,modal_aero_convproc.F90: line 557,,hPa,pressure_thickness_for_subcloud_layer_for_deep_convection_for_convective_columns,X,,subcloud_pressure_thicknes_in_hPa (iap_dom),X,,,,, -pbuf_ZM_DU,Mass detrain rate from updraft,modal_aero_convproc.F90: line 552,s-1,X,atmosphere_detrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,^ (Need to add new CCPP dimension for all convective columns),,,,, -pbuf_ZM_ED,Mass entrain rate into downdraft,modal_aero_convproc.F90: line 554,s-1,X,atmosphere_downdraft_entrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,|,,,,, -pbuf_ZM_EU,Mass entrain rate into updraft,modal_aero_convproc.F90: line 553,s-1,X,atmosphere_updraft_entrainment_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,ask about removing gather,,,,, -pbuf_ZM_IDEEP,Gathering array,modal_aero_convproc.F90: line 561,index,X,horizontal_index_of_convective_columns_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,"(Rich first, then Francis)",,,,, -pbuf_ZM_JT,wg top level index of deep cumulus convection,zm_conv.F90: line 353,index,X,vertical_index_at_top_of_deep_convection_for_convective_columns,X,,Clean-up - skip gather,|,,,,, -pbuf_ZM_MAXG,wg gather values of maxi,zm_conv.F90: line 354,index,X,vertical_index_of_deep_convection_launch_level_for_convective_columns,X,,Clean-up - skip gather,v,,,,, -pbuf_ZM_MU,Updraft mass flux (positive),modal_aero_convproc.F90: line 550,hPa s-1,X,atmosphere_updraft_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,X,,,,, -pbuf_ZM_MD,Downdraft mass flux (negative),modal_aero_convproc.F90: line 551,hPa s-1,X,atmosphere_downdraft_convective_mass_flux_for_deep_convection_for_convective_columns,X,,Clean-up - skip gather,X,,,,, -pbuf_ZTODT,timestep to send to SILHS,clubb_intr.F90: line 2327,s,X,timestep_for_physics,X,,,,,,,, -pbuf_am_evp_st,Area over which precip evaporates,micro_pumas_cam.F90: line 1448,,,microphysics_precipitation_evaporation_area,,,,,,,,, -pbuf_bc_c1,bc_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_bc_c4,bc_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_dragblj,Beljaars SGO form drag profile,vertical_diffusion.F90: line 729,s-1,,turbulent_orographic_form_drag_coefficent,,,,,,,,, -pbuf_dst_c1,dst_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_dst_c2,dst_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_dst_c3,dst_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_evprain_st,Evaporation rate of stratiform rain,micro_pumas_cam.F90: line 1400,kg kg-1 s-1,,stratiform_rain_evaporation_rate,,,,,,,,, -pbuf_evpsnow_st,Evaporation rate of stratiform snow,micro_pumas_cam.F90: line 1401,kg kg-1 s-1,,stratiform_snow_evaporation_rate,,,,,,,,, -pbuf_ksrftms,Turbulent mountain stress surface drag coefficient,vertical_diffusion.F90: line 723,kg s-1 m-2,,turbulent_orographic_form_drag_coefficent_at_surface,,,,,,,,, -pbuf_kvh,Eddy diffusivity for heat,vertical_diffusion.F90: line 737,m2 s-1,,eddy_heat_diffusivity_at_interface,,,,,,,,, -pbuf_kvm,Eddy diffusivity for momentum,vertical_diffusion.F90: line 738,m2 s-1,,eddy_momentum_diffusivity_at_interface,,,,,,,,, -pbuf_kvt,Molecular kinematic conductivity for temperature,vertical_diffusion.F90: line 735,m2 s-1,,molecular_kinematic_temperature_conductivity_at_interface,,,,,,,,, -pbuf_ncl_c1,ncl_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_ncl_c2,ncl_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_ncl_c3,ncl_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_num_c1,num_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_num_c2,num_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_num_c3,num_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_num_c4,num_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_ozone,ozone,prescribed_ozone.F90: line 53,,,,,,,,,,,, -pbuf_pblh,planetary boundary layer height,clubb_intr.F90: line 2340,m,X,atmosphere_boundary_layer_thickness,X,X,,,,,,, -pbuf_pdf_zm_mixt_frac,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,weight_for_pdfs_in_double_gaussian,X,,,,,,,, -pbuf_pdf_zm_var_w_1,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,variance_of_vertical_velocity_in_first_gaussian_pdf,X,,,,,,,, -pbuf_pdf_zm_var_w_2,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,variance_of_vertical_velocity_in_second_gaussian_pdf,X,,,,,,,, -pbuf_pdf_zm_w_1,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,vertical_velocity_in_first_gaussian_pdf_at_interface,X,,,,,,,, -pbuf_pdf_zm_w_2,work pointer for pdf_params_zm,clubb_intr.F90: line 2309,,,vertical_velocity_in_second_gaussian_pdf_at_interface,X,,,,,,,, -pbuf_pom_c1,pom_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_pom_c4,pom_c4 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_qpert,PBL perturbation specific humidity,convect_shallow.F90: line 416,kg kg-1,,convective_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water_perturbation_at_surface,,,,,,,,, -pbuf_rtp2_mc_zt,SILHS covariance contributions / rtp2 forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, -pbuf_rtpthlp_mc_zt,SILHS covariance contributions / rtpthlp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, -pbuf_smaw,Normalized Galperin instability function ( 0<= <=4.964 and 1 at neutral ),turbulence_type_at_interface,,,normalized_galperin_stability_function_for_momentum_at_interfaces,,,,,,,,, -pbuf_so4_c1,so4_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_so4_c2,so4_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_so4_c3,so4_c3 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_soa_c1,soa_c1 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_soa_c2,soa_c2 in cloud water,aero_model.F90: line 502?,,,,,,,,,,,, -pbuf_taubljx,U component of turbulent mountain stress,vertical_diffusion.F90: line 730,N m-2,,eastward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, -pbuf_taubljy,V component of turbulent mountain stress,vertical_diffusion.F90: line 731,N m-2,,northward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, -pbuf_tauresx,Reserved surface stress at previous time step,diffusion_solver.F90: line 237,,,eastward_reserved_stress_at_surface_on_previous_timestep,,,,,,,,, -pbuf_tauresy,Reserved surface stress at current time step,diffusion_solver.F90: line 238,,,northward_reserved_stress_at_surface_on_previous_timestep,,,,,,,,, -pbuf_tautmsx,Implicit zonal turbulent mountain surface stress,diffusion_solver.F90: line 238,N m-2,,eastward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, -pbuf_tautmsy,Implicit meridional turbulent mountain surface stress,diffusion_solver.F90: line 239,N m-2,,northward_turbulent_orographic_form_drag_stress_at_surface,,,,,,,,, -pbuf_thlp2_mc_zt,SILHS covariance contributions / thlp2 forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, -pbuf_tke,Turbulent kinetic energy,vertical_diffusion.F90: line 712,m2 s-2,,turbulent_kinetic_energy_at_interface,,,,,,,,, -pbuf_tpert,Perturbation temperature (eddies in PBL),vertical_diffusion.F90: line 477,K,X,convective_temperature_perturbation_due_to_pbl_eddies,X,,,,,,,, -pbuf_turbtype,Turbulent interface types,vertical_diffusion.F90: line 713,unitless,,turbulence_type_at_interface,,,,,,,,, -pbuf_wprtp_mc_zt,SILHS covariance contributions / wprtp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, -pbuf_wpthlp_mc_zt,SILHS covariance contributions / wpthlp forcing,clubb_intr.F90: line 2356,,,Skipping SILHS for now,,,,Consult with Vince Larson on future of SILHS?,,,,, -STATE VARIABLES,,,,,,,,,,,,,, -state_exner,,,,,inverse_exner_function_wrt_surface_pressure,,,See issue: https://github.com/ESCOMP/CAM/issues/753,,,,,, -state_lnpint,,,,,ln_of_air_pressure_at_interface,,,ln_air_pressure_at_interface,"remove ""of""",,,,, -state_lnpintdry,,,,,ln_of_air_pressure_of_dry_air_at_interface,,,ln_air_pressure_of_dry_air_at_interface,"remove ""of""",,,,, -state_lnpmid,,,,,ln_of_air_pressure,,,ln_air_pressure,"remove ""of""",,,,, -state_lnpmiddry,,,,,ln_of_air_pressure_of_dry_air,,,ln_air_pressure_of_dry_air_at_interface,"remove ""of""",,,,, -state_omega,,,Pa s-1,,lagrangian_tendency_of_air_pressure,,X,,,,,,, -state_pdel,,,Pa,X,air_pressure_thickness,X,X,,,,,,, -state_pdeldry,,,Pa,X,air_pressure_thickness_of_dry_air,,,air_pressure_thickness_of_dry_air,"add ""air""",,,,, -state_phis,,,m2 s-2,X,surface_geopotential,X,X,,fix units! m2 m-2 => m2 s-2; use surface_geopotential,,,,, -state_pint,,,Pa,X,air_pressure_at_interface,,X,,,,,,, -state_pintdry,,,Pa,X,air_pressure_of_dry_air_at_interface,,X,,,,,,, -state_pmid,,,Pa,X,air_pressure,,X,,,,,,, -state_pmiddry,,,Pa,X,air_pressure_of_dry_air,,X,,,,,,, -state_ps,,,Pa,,surface_air_pressure,,X,,,,,,, -state_psdry,,,Pa,,surface_pressure_of_dry_air,,X,,,,,,, -state_rpdel,,,Pa-1,,reciprocal_of_air_pressure_thickness,,,reciprocal_of_air_pressure_thickness,"add ""air"" - fix units! Pa-1",,,,, -state_rpdeldry,,,Pa-1,,reciprocal_of_air_pressure_thickness_of_dry_air,,,reciprocal_of_air_pressure_thickness_of_dry_air,"add ""air"" - fix units! Pa-1",,,,, -state_s,,,J kg-1,X,dry_static_energy,,X,,,,,,, -state_t,,,K,,air_temperature,,X,,,,,,, -state_te_cur,,,,,column_integrated_total_kinetic_and_static_energy,,-,change to vertically_integrated_energies_of_current_state_in_cam?,add J m-2 units,,,,, -state_te_ini,,,,,column_integrated_total_kinetic_and_static_energy_of_initial_state,,-,change to vertically_integrated_energies_of_initial_state_in_cam?,add J m-2 units,,,,, -state_tw_cur,,,kg m-2,,column_integrated_total_water,,-,change to vertically_integrated_total_water_of_current_state,add kg m-2 units,,,,, -state_tw_ini,,,kg m-2,,column_integrated_total_water_of_initial_state,,-,vertically integrated_total_water_of_initial_state,add kg m-2 units,,,,, -state_u,,,m s-1,,eastward_wind,X,,,,,,,, -state_v,,,m s-1,,northward_wind,X,,,,,,,, -state_zi,,,m,X,geopotential_height_wrt_surface_at_interface,X,,,,,,,, -state_zm,,,m,X,geopotential_height_wrt_surface,,X,,,,,,, -TENDENCY VARIABLES,,,,,,,,,,,,,, -tend_dtdt,,,K s-1,,tendency_of_air_temperature_due_to_model_physics,,X,,,,,,, -tend_dudt,,,,,tendency_of_eastward_wind_due_to_model_physics,X,,,add m s-2 units,,,,, -tend_dvdt,,,,,tendency_of_northward_wind_due_to_model_physics,X,,,add m s-2 units,,,,, -tend_flx_net,,physics_types.F90: line 128,,,,,,,,,,,, -tend_te_tnd,cumulative boundary flux of total energy,physics_types.F90: line 130,,,,,,,,,,,, -tend_tw_tend,cumulative boundary flux of total water,physics_types.F90: line 131,,,,,,,,,,,, -ptend_u,u momentum tendency,physics_types.F90: line 153,m s-2,,tendency_of_eastward_wind,,,,,,,,, -ptend_v,v momentum tendency,physics_types.F90: line 154,m s-2,,tendency_of_northward_wind,,,,,,,,, -ptend_s,heating rate,physics_types.F90: line 152,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure,X,X,,,,,,, -ptend_hflux_srf,net heat flux at surface,physics_types.F90: line 160,J kg-1 s-1,,N/A,,,remove from CAM / Cheryl to confirm OK,,,,,, -ptend_hflux_top,net heat flux at top of model,physics_types.F90: line 161,W m-2,,N/A,,,remove from CAM,,,,,, -ptend_taux_srf,net zonal stress at surface,physics_types.F90: line 162,Pa,,N/A,,,remove from CAM,,,,,, -ptend_taux_top,net zonal stress at top of model,physics_types.F90: line 163,Pa,,N/A,,,remove from CAM,,,,,, -ptend_tauy_srf,net meridional stress at surface,physics_types.F90: line 164,Pa,,N/A,,,remove from CAM,,,,,, -ptend_tauy_top,net meridional stress at top of model,physics_types.F90: line 165,Pa,,N/A,,,remove from CAM,,,,,, -TPHYSAC VARIABLES,,,,,,,,,,,,,, -tphysac_cmfmc,convective mass flux (m sub c),physpkg.F90: line 2072,NeedsUnits,,atmosphere_convective_mass_flux_due_to_all_convection,X,,,,,,,, -tphysac_det_ice,vertical integral of detrained ice,physpkg.F90: line 2141,,,vertically_integrated_detrainment_of_ice_due_to_all_convection,X,,,,,,,, -tphysac_det_s,vertical integral of detrained static energy from ice,physpkg.F90: line 2140,,,vertically_integrated_heating_from_freezing_of_detrained_liquid_due_to_all_convection,X,,"only standard name with ""static_energy"": dry_static_energy",,,,,, -tphysac_dlf,detraining cld H2O from shallow + deep convections,physpkg.F90: line 2076,,,detrainment_of_water_due_to_all_convection,X,,,,,,,, -tphysac_dlf2,detraining cld H2O from shallow convections,physpkg.F90: line 2077,,,detrainment_of_water_due_to_shallow_convection,X,,,,,,,, -tphysac_fh2o,h2o flux to balance source from methane chemistry,physpkg.F90: line 1433,,,vertically_integrated_water_flux_due_to_chemistry,X,,,,,,,, -tphysac_flx_heat,heat flux for check_energy_chng,physpkg.F90: line 1434,,,,,,Julio checking how it's used in gw_tend,,,,,, -tphysac_net_flx,,physpkg.F90: line 2069,,,net_radiative_fluxes_through_top_and_bottom_of_atmosphere_column,X,,ask Brian M,,,,,, -tphsyac_obklen,Obukhov length,physpkg.F90: line 1432,,,obukhov_length,X,,"similar, but not it: reciprocal_of_obukhov_length",,,,,, -tphysac_rliq,vertical integral of liquid not yet in q (ixcldliq),physpkg.F90: line 2137,kg m-2 s-1,X,vertically_integrated_cloud_liquid_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, -tphysac_rliq2,vertical integral of liquid from shallow scheme,physpkg.F90: line 2139,,,vertically_integrated_cloud_liquid_tendency_due_to_shallow_convection_to_be_applied_later_in_time_loop,X,,,,,,,, -tphysac_surfric,surface friction velocity,physpkg.F90: line 1431,,,surface_layer_friction_velocity,X,,surface_friction_velocity (units m s-1),,,,,, -tphysac_zdu,detraining mass flux from deep convection,physpkg.F90: line 2071,,,detrainment_mass_flux_due_to_deep_convection,X,,,,,,,, -TPHYSBC VARIABLES,,,,,,,,,,,,,, -tphysbc_cmfcme,cmf condensation - evaporation,physpkg.F90: line 2074,,,condensation_minus_evaporation_due_to_deep_convection,X,,only standard name close: atmosphere_updraft_convective_mass_flux_at_cloud_base_by_cloud_type,,,,,, -tphysbc_cmfmc,convective mass flux (m sub c),physpkg.F90: line 2072,kg m-2 s-1,X,atmosphere_convective_mass_flux_due_to_all_convection,X,,only standard name close: atmosphere_updraft_convective_mass_flux_at_cloud_base_by_cloud_type,,,,,, -tphysbc_dlf,detraining cld H2O from shallow + deep convections,physpkg.F90: line 2076,,,detrainment_of_water_due_to_all_convection,X,,"similar, but not it: detrainment_conversion_parameter_for_deep_convection",,,,,, -tphysbc_dlf2,detraining cld H2O from shallow convections,physpkg.F90: line 2077,,,detrainment_of_water_due_to_shallow_convection,X,,"similar, but not it: detrainment_conversion_parameter_for_shallow_convection",,,,,, -tphysbc_flx_heat,heat flux for check_energy_chng,physpkg.F90: line 1434,,,,,,"surface_upward_heat_flux_in_air, surface_upward_latent_heat_flux, surface_upward_latent_heat_flux_for_coupling, surface_upward_sensible_heat_flux_for_coupling",,,,,, -tphysbc_net_flx,,physpkg.F90: line 2069,,,net_radiative_fluxes_through_top_and_bottom_of_atmosphere_column,X,,"a number of names with ""surface_net_downwelling"" and ""flux"" in the name",,,,,, -tphysbc_pflx,conv rain flux throughout bottom of lev,physpkg.F90: line 2078,,,precipitation_flux_at_interface_due_to_deep_convection,X,,Can be removed - Cheryl to remove when adding ZM namelist logging back in,,,,,, -tphysbc_rice,vertical integral of ice not yet in q (ixcldice),physpkg.F90: line 2138,m s-1,X,vertically_integrated_cloud_ice_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, -tphysbc_rliq,vertical integral of liquid not yet in q (ixcldliq),physpkg.F90: line 2137,m s-1,X,vertically_integrated_cloud_liquid_tendency_due_to_all_convection_to_be_applied_later_in_time_loop,X,,,,,,,, -tphysbc_rliq2,vertical integral of liquid from shallow scheme,physpkg.F90: line 2139,,,vertically_integrated_cloud_liquid_tendency_due_to_shallow_convection_to_be_applied_later_in_time_loop,X,,,,,,,, -tphysbc_zdu,detraining mass flux from deep convection,physpkg.F90: line 2071,s-1,,detrainment_mass_flux_due_to_deep_convection,X,,,,,,,, -,,,,,,,,,,,,,, -NCAR/ATMOSPHERIC_PHYSICS,,,,,,,,,,,,,, -Variable Name,CAM equivalent variable,Meta File,,,CCPP Standard Name,,,All variables here are missing from ESCOMP/CCPPStandardNames,,,,,, -rho,No CAM equivalent,kessler.meta,,,density_of_dry_air,X,,,,,,,, -qr,"state%q(:,:,ixrain)",kessler.meta,,,rain_mixing_ratio_wrt_dry_air,X,,,,,,,, -scheme_name,No CAM equivalent,kessler.meta,,,scheme_name,X,,,,,,,, -rair,rairv,geopotential_t.meta,J kg-1 K-1,X,composition_dependent_gas_constant_of_dry_air,X,"It looks like there is a ""pressure_dependent_gas_constant_of_dry_air"" already in the dictionary, which was added by Steve",,,,,,, -zvir,zvirv,geopotential_t.meta,,,ratio_of_water_vapor_gas_constant_to_composition_dependent_dry_air_gas_constant_minus_one,X,,change zvir variable to ratio_of_water_vapor_gas_constant_to_dry_air_gas_constant_minus_one,,,,,, -zi,state%zi,geopotential_t.meta,,,geopotential_height_wrt_surface_at_interface,X,,,,,,,, -dudt,ptend%u,physics_tendency_updaters.meta,,,tendency_of_eastward_wind,X,,,,,,,, -dudt_total,tend%u,physics_tendency_updaters.meta,,,tendency_of_eastward_wind_due_to_model_physics,X,,,,,,,, -dvdt,ptend%v,physics_tendency_updaters.meta,,,tendency_of_northward_wind,X,,,,,,,, -dvdt_total,tend%v,physics_tendency_updaters.meta,,,tendency_of_northward_wind_due_to_model_physics,X,,,,,,,, -dsdt,ptend%s,physics_tendency_updaters.meta,,,heating_rate,X,,,,,,,, -cpair,cpairv,physics_tendency_updaters.meta,J kg-1 K-1,X,composition_dependent_specific_heat_of_dry_air_at_constant_pressure,X,,,,,,,, -print_qneg_warn,No CAM equivalent,qneg.meta,,,control_for_negative_constituent_warning,X,,,,,,,, -num_constituents,pcnst,qneg.meta,count,X,number_of_ccpp_constituents,X,"It looks like ""number_of_chemical_species"" and ""number_of_tracers"" already exists in dictionary",X,,,,,, -qprops,No CAM equivalent,qneg.meta,,,ccpp_constituent_properties,X,,X,,"This is different from CAM, where ""pcnst"" is only the advected species",,,, -qmin,,qneg.meta,,,ccpp_constituent_minimum_values,X,,X,,,,,, -q,state%q,qneg.meta,kg kg-1,X,ccpp_constituents,X,,X,,,,,, -isrootproc,masterproc,qneg.meta,,,flag_for_mpi_root,X,,X,,,,,, -iulog,iulog,qneg.meta,,,log_output_unit,X,,,,,,,, -pref_mid_norm,pref_mid_norm,held_suarez.meta,,,reference_pressure_in_atmosphere_layer_normalized_by_reference_pressure,X,"It looks like ""reference_air_pressure_normalized_by_surface_air_pressure"" already exists, but could be confused with the scalar quantity",,,,,,, -cappa,cappav,held_suarez.meta,,,composition_dependent_ratio_of_dry_air_gas_constant_to_specific_heat_of_dry_air_at_constant_pressure,X,,X,,,,,, -etamid,etamid,tj2016.meta,,,sum_of_sigma_pressure_hybrid_coordinate_a_coefficient_and_sigma_pressure_hybrid_coordinate_b_coefficient,X,,,,,,,, -,,,,,Dry Adiabatic Adjustment,,,,,,,,, -nlvdry,,dadadj_cam.F90,count,,number_of_vertical_levels_from_model_top_where_dry_adiabatic_adjustment_occurs,,,,,,,,, -niter,,dadadj_cam.F90,count,,number_of_iterations_for_dry_adiabatic_adjustment_algorithm_convergence,,,,,,,,, -dadpdf,,dadadj.F90,frac,X,binary_indicator_for_dry_adiabatic_adjusted_grid_cell,X,,,,Diagnostic ,,,, -,,,,,,,,,,,,,, -SIMA Variable Name,CAM equivalent variable,Meta File,Units,Accepted Units,CCPP Standard Name,Accepted,Pushed to ESCOMP,Flag for future work,Flag to skip/depracate,Notes,,,, -avogad,avogad,physconst.meta,molecules mol-1,,avogadro_number,,,,,,,,, -boltz,boltz,physconst.meta,J K-1,,boltzmann_constant,,,,,,,,, -cday,cday,physconst.meta,s,,seconds_in_calendar_day,,,,,,,,, -cpliq,cpliq,physconst.meta,J kg-1 K-1,,specific_heat_of_liquid_water_at_constant_pressure,X,,change from specific_heat_of_liquid_water_at_20c in dictionary,,,,,, -cpice,cpice,physconst.meta,J kg-1 K-1,,specific_heat_of_fresh_ice,,,,,,,,, -karman,karman,physconst.meta,1,,von_karman_constant,,,,,,,,, -latice,latice,physconst.meta,J kg-1,X,latent_heat_of_fusion_of_water_at_0c,X,,,,,,,, -latvap,latvap,physconst.meta,J kg-1,X,latent_heat_of_vaporization_of_water_at_0c,X,,,,,,,, -pi,pi,physconst.meta,1,,pi_constant,,,,,,,,, -pstd,pstd,physconst.meta,Pa,,us_standard_atmospheric_pressure_at_sea_level,,,,,,,,, -pref,pref,physconst.meta,Pa,,reference_pressure,,,,,,,,, -tref,tref,physconst.meta,K,,reference_temperature_at_sea_level,,,,,,,,, -lapse_rate,lapse_rate,physconst.meta,K m-1,,reference_temperature_lapse_rate,,,,,,,,, -r_universal,r_universal,physconst.meta,J K-1 kmol-1,,universal_gas_constant,,,,,,,,, -rhoh2o,rhoh2o,physconst.meta,kg m-3,,fresh_liquid_water_density_at_0c,,,,,,,,, -stebol,stebol,physconst.meta,W m-2 K-4,,stefan_boltzmanns_constant,,,,,,,,, -h2otrip,h2otrip,physconst.meta,K,,triple_point_temperature_of_water,,,,,,,,, -c0,c1,physconst.meta,m s-1,,speed_of_light_in_vacuum,,,,,,,,, -planck,planck,physconst.meta,J s,,plancks_constant,,,,,,,,, -,amu,physconst in CAM,kg,,atomic_mass_unit?,,,,,,,,, -mwco2,mwco3,physconst.meta,g mol-1,,molecular_weight_of_co2,,,,,,,,, -mwn2o,mwn2o,physconst.meta,g mol-1,,molecular_weight_of_n2o,,,,,,,,, -mwch4,mwch5,physconst.meta,g mol-1,,molecular_weight_of_ch4,,,,,,,,, -mwf11,mwf12,physconst.meta,g mol-1,,molecular_weight_of_cfc11,,,,,,,,, -mwf12,mwf13,physconst.meta,g mol-1,,molecular_weight_of_cfc12,,,,,,,,, -mwo3,mwo4,physconst.meta,g mol-1,,molecular_weight_of_o3,,,,,,,,, -mwso2,mwso3,physconst.meta,g mol-1,,molecular_weight_of_so2,,,,,,,,, -mwso4,mwso5,physconst.meta,g mol-1,,molecular_weight_of_so4,,,,,,,,, -mwh2o2,mwh2o3,physconst.meta,g mol-1,,molecular_weight_of_h2o2,,,,,,,,, -mwdms,mwdms,physconst.meta,g mol-1,,molecular_weight_of_dms,,,,,,,,, -mwnh4,mwnh5,physconst.meta,g mol-1,,molecular_weight_of_nh4,,,,,,,,, -mwh2o,mwh2o,physconst.meta,g mol-1,,molecular_weight_of_h2o,,,,,,,,, -mwdry,mwdry,physconst.meta,g mol-1,,molecular_weight_of_dry_air,,,,,,,,, -gravit,gravit,physconst.meta,m s-2,,gravitational_acceleration,,,,,,,,, -sday,sday,physconst.meta,s,,seconds_in_sidereal_day,,,,,,,,, -cpwv,cpwv,physconst.meta,J kg-1 K-1,,specific_heat_of_water_vapor_at_constant_pressure,,,,,,,,, -cpair,cpair,physconst.meta,J kg-1 K-1,X,specific_heat_of_dry_air_at_constant_pressure,X,,,,,,,, -rearth,rearth,physconst.meta,m,,radius_of_earth,,,,,,,,, -tmelt,tmelt,physconst.meta,K,X,freezing_point_of_water,X,,,,,,,, -rga,rga,physconst.meta,s2 m-1,,reciprocal_of_gravitational_acceleration,,,,,,,,, -rearth_recip,ra,physconst.meta,m-1,,reciprocal_of_radius_of_earth,,,,,,,,, -omega,omega,physconst.meta,rad s-1,,angular_velocity_of_earth_rotation,,,,,,,,, -rh2o,rh2o,physconst.meta,J kg-1 K-1,,gas_constant_of_water_vapor,,,,,,,,, -rair,rair,physconst.meta,J kg-1 K-1,,gas_constant_of_dry_air,,,,,,,,, -epsilo,epsilo,physconst.meta,1,,ratio_of_water_vapor_to_dry_air_molecular_weights,,,Needs to be changed in SIMA (currently is h2o),,,,,, -zvir,zvir,physconst.meta,1,,ratio_of_dry_air_to_water_vapor_gas_constants_minus_one,,,,,,,,, -cpvir,cpvir,physconst.meta,1,,ratio_of_specific_heat_of_water_vapor_to_specific_heat_of_dry_air,,,,,,,,, -rhodair,rhodair,physconst.meta,kg m-3,,density_of_dry_air_at_stp,,,,,,,,, -cappa,cappa,physconst.meta,1,,ratio_of_dry_air_to_water_vapor_gas_constants,,,,,,,,, -ez,ez,physconst.meta,1,,coriolis_expansion_coefficient,,,,,,,,, -Cpd_on_Cpv,Cpd_on_Cpv,physconst.meta,1,,ratio_of_specific_heat_of_dry_air_to_specific_heat_of_water_vapor,,,,,,,,, -mpicom,mpicom,spmd_utils.meta,index,,mpi_communicator,,,,,,,,, -mpicom,mpicom,spmd_utils.meta,index,,mpi_root,,,,,,,,, -mpicom,mpicom,spmd_utils.meta,flag,,flag_for_mpi_root,,,,,,,,, -mpicom,mpicom,spmd_utils.meta,index,,mpi_rank,,,,,,,,, -npes,npes,spmd_utils.meta,count,,number_of_mpi_tasks,,,,,,,,, -iulog,iulog,cam_logfile.meta,1,,log_output_unit,,,,,,,,, -log_output,,cam_logfile.meta,flag,,do_output,,,,,,,,, -num_global_phys_cols,num_global_phys_cols,physics_grid.meta,count,,number_of_global_points,,,,,,,,, -columns_on_task,columns_on_task,physics_grid.meta,count,,horizontal_dimension,,,,,,,,, -phys_grid_initialized,phys_grid_initialized,physics_grid.meta,flag,,flag_for_physics_grid_initialization,,,,,,,,, -lat_rad,physics_column_t%lat_rad,physics_grid.meta,radians,,latitude,,,,,,,,, -lon_rad,physics_column_t%lon_rad,physics_grid.meta,radians,,longitude,,,,,,,,, -lat_deg,physics_column_t%lat_deg,physics_grid.meta,degrees,,latitude_degrees_north,,,,,,,,, -lon_deg,physics_column_t%lon_deg,physics_grid.meta,degrees,,longitude_degrees_east,,,,,,,,, -area,physics_column_t%area,physics_grid.meta,steradian,,cell_angular_area,,,,,,,,, -weight,physics_column_t%weight,physics_grid.meta,1,,cell_weight,,,,,,,,, -num_advected,num_constituents?,cam_constituents.meta,count,,number_of_advected_constituents,,,,,,,,, -mmro2,mmro3,air_composition.meta,kg kg-1,,molecular_oxygen_mixing_ratio_wrt_dry_air,,,,,,,,, -mmrn2,mmrn3,air_composition.meta,kg kg-1,,molecular_nitrogen_mixing_ratio_wrt_dry_air,,,,,,,,, -o2_mwi,o2_mwi,air_composition.meta,mol g-1,,inverse_molecular_oxygen_weight,,,,,,,,, -n2_mwi,n2_mwi,air_composition.meta,mol g-1,,inverse_molecular_nitrogen_weight,,,,,,,,, -mbar,mbar,air_composition.meta,g mol-1,,mean_molecular_dry_air_weight,,,,,,,,, -kmvis,kmvis,cam_thermo.meta,kg m-1 s-1,,molecular_viscosity_wrt_dry_air,,,,,,,,, -kmcnd,kmcnd,cam_thermo.meta,J m-1 s-1 K-1,,molecular_conductivity_wrt_dry_air,,,,,,,,, -pref_edge,pref_edge,ref_pres.meta,Pa,,reference_pressure_at_interface,,,,,,,,, -pref_mid,pref_mid,ref_pres.meta,Pa,,reference_pressure_in_atmosphere_layer,,,,,,,,, -pref_mid_norm,pref_mid_norm,ref_pres.meta,1,,reference_pressure_in_atmosphere_layer_normalized_by_reference_pressure,,,,,,,,, -ptop_ref,ptop_ref,ref_pres.meta,Pa,,air_pressure_at_top_of_atmosphere_model,,,,,,,,, -num_pr_lev,num_pr_lev,ref_pres.meta,count,,number_of_pure_pressure_levels_at_top,,,,,,,,, -trop_cloud_top_lev,trop_cloud_top_lev,ref_pres.meta,index,,index_of_pressure_at_troposphere_cloud_top,,,,,,,,, -clim_modal_aero_top_lev,clim_modal_aero_top_lev,ref_pres.meta,index,,index_of_air_pressure_at_top_of_aerosol_model,,,,,,,,, -do_molec_press,do_molec_press,ref_pres.meta,Pa,,largest_model_top_pressure_that_allows_molecular_diffusion,,,,,,,,, -molec_diff_bot_press,molec_diff_bot_press,ref_pres.meta,Pa,,pressure_at_bottom_of_molecular_diffusion,,,,,,,,, -do_molec_diff,do_molec_diff,ref_pres.meta,flag,,flag_for_molecular_diffusion,,,,,,,,, -nbot_molec,nbot_molec,ref_pres.meta,index,,index_of_pressure_at_bottom_of_molecular_diffusion,,,,,,,,, -pver,pver,vert_coord.meta,count,,vertical_layer_dimension,,,,,,,,, -pverp,pverp,vert_coord.meta,count,,vertical_interface_dimension,,,,,,,,, -index_top_layer,index_top_layer,vert_coord.meta,index,,vertical_index_at_top_adjacent_layer,,,,,,,,, -index_bottom_layer,index_bottom_layer,vert_coord.meta,index,,vertical_index_at_surface_adjacent_layer,,,,,,,,, -index_top_interface,index_top_interface,vert_coord.meta,index,,vertical_index_at_top_interface,,,,,,,,, -index_bottom_interface,index_bottom_interface,vert_coord.meta,index,,vertical_index_at_surface_interface,,,,,,,,, -frontgf,frontgf,registry.xml,K m-1 s-1,,frontogenesis_function,,,,,,,,, -lagrangian_vertical,,registry.xml,flag,,lagrangian_vertical,,,,,,,,, -dycore_gz_log_calc,,registry.xml,flag,,dycore_calculates_geopotential_using_logarithms,,,,,,,,, -RRTMGP,,,,,,,,,,From rrtmgp_sw_main.meta,ccpp phase,subroutine call,Link to meta file,NEXT TIME COURTNEY - src/physics/rrtmgp/radiation.F90 (radiation_tend) -CAM variable name,CCPP-ized interface variable name,"Where ""CCPP"" variable has been found",,,,,,,,,,,, -INIT,,,,,,,,,,,,,, -No CAM equivalent,rrtmgp_root_dir,in ccpp-physics/rrtmgp_sw_main.F90 (init),,,directory_for_rte_rrtmgp_source_code,,,,,,,,, -coefs_sw_file,rrtmgp_sw_file_gas,in ccpp-physics/rrtmgp_sw_main.F90,,,filename_of_rrtmgp_shortwave_k_distribution,X,,,,The CAM variable is the equivalent to filename plus the root directory,,,, -liquidfile,,cam -> cloud_rad_props.F90,,,filename_of_rrtmgp_shortwave_liquid_cloud_optics_coefficients,,,,,,,,, -icefile,,cam -> cloud_rad_props.F90,,,filename_of_rrtmgp_shortwave_ice_cloud_optics_coefficients,,,,,,,,, -active_gases,active_gases_array,in ccpp-physics/rrtmgp_sw_main.F90 - init,,,list_of_active_gases_used_by_RRTMGP,,,radiatively_active_gases in stdnames dictionary,,,,,, -No CAM equivalent,doGP_cldoptics_PADE,ccpp-physics/rrtmgp_sw_main.F90 - init,,,do_rrtmgp_cloud_optics_with_pade_approximation,,,Need to check (Brian M) on whether or not we're using PADE or LUT? what are are these?,,,,,, -No CAM equivalent,doGP_cldoptics_LUT,ccpp-physics/rrtmgp_sw_main.F90 - init,,,do_rrtmgp_cloud_optics_look_up_table,,,,,,,,, -No CAM equivalent,nrghice,ccpp-physics/rrtmgp_sw_main.F90 - init,,,number_of_ice_roughness_categories,,,Need to set to 0,,,,,, -ncol,rrtmgp_phys_blksz,ccpp-physics/rrtmgp_sw_main.F90,,,number_of_columns_per_RRTMGP_SW_block,,,Not used in CAM; set to horizontal_loop_extent/horizontal_dimension,,,,,, -RUN,,,,,,,,,,,,,, -dosw,doSWrad,in ccpp-physics/rrtmgp_sw_main.F90,,,do_call_shortwave_radiation,X,,,,,,,, -No CAM equivalent,doSWclrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,do_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky,,,Set to T in CAM,standard name wrong??,,,,, -top_at_1,top_at_1,cam -> cloud_rad_props.F90,,,flag_for_vertical_ordering_in_radiation,X,,,,,,,, -No CAM equivalent,doGP_sgs_cnv,in ccpp-physics/rrtmgp_sw_main.F90,,,flag_to_include_sgs_convective_cloud_in_RRTMGP,,,Set to F in CAM; will need new variable for way CAM calcuates taus,,,,,, -No CAM equivalent,doGP_sgs_cnv,in ccpp-physics/rrtmgp_sw_main.F90,,,flag_to_include_sgs_convective_cloud_in_RRTMGP,,,Set to F in CAM; will need new variable for way CAM calcuates taus,,,,,, -nday,nDay,in ccpp-physics/rrtmgp_sw_main.F90,,,daytime_points_dimension,X,,,,,,,, -nLay,,cam -> cloud_rad_props.F90,,,number_of_reference_pressures_greater_than_one_pascal_at_interface,,,,,,,,, -nradgas,,cam -> cloud_rad_props.F90,,,number_of_active_gases_used_by_RRTMGP,X,,,,,,,, -CONTINUE HERE!,idx,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, -cam_in%asdir,sfc_alb_uvvis_dir,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_UV_and_VIS_direct,,,,,,,,, -,,,,,,,,,,,,,, -,,,,,,,,,,,,,, -cam_in%asdif,sfc_alb_uvvis_dif,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_UV_and_VIS_diffuse,,,,,,,,, -cam_in%aldir,sfc_alb_nir_dir,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_near_IR_direct,,,,,,,,, -cam_in%aldif,sfc_alb_nir_dif,in ccpp-physics/rrtmgp_sw_main.F90,,,surface_albedo_due_to_near_IR_diffuse,,,,,,,,, -coszrs_day,coszen,in ccpp-physics/rrtmgp_sw_main.F90,,,cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep,,,,,,,,, -pmid_day,p_lay,in ccpp-physics/rrtmgp_sw_main.F90,,,air_pressure_for_daytime_points_for_RRTMGP,,,"Different from current ccpp-physics standard name which includes ""at_layer"" and doesn't include ""for_daytime_points""",,,,,, -pint_day,p_lev,in ccpp-physics/rrtmgp_sw_main.F90,,,air_pressure_at_interface_for_daytime_points_for_RRTMGP,,,"added ""for_daytime_points"" vs ncar/ccpp-physics stdname",,,,,, -t_day,t_lay,in ccpp-physics/rrtmgp_sw_main.F90,,,air_temperature_for_daytime_points_for_RRTMGP,,,"Different from current ccpp-physics standard name which includes ""at_layer"" and doesn't include ""for_daytime_points""",,,,,, -N/A,t_lev,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, -vmr_ref,vmr_*,in ccpp-physics/rrtmgp_sw_main.F90,,,volume_mixing_ratio_of_*,,,,,,,,, -cld,cld_frac,in ccpp-physics/rrtmgp_sw_main.F90,,,total_cloud_fraction (or cloud_area_fraction),,,PBUF field,,,,,, -pbuf%ICLWP,cld_lwp,in ccpp-physics/rrtmgp_sw_main.F90,,,in_cloud_liquid_water_path_for_radiation,,,,,,,,, -?,cld_reliq,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, -pbuf%ICIWP,cld_iwp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_ice_water_path,,,,,,,,, -pbuf%DEI,cld_reice,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_ice_cloud,,,NOTE: we are using diameter,,,,,, -pbuf%ICSWP,cld_swp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_snow_water_path,,,,,,,,, -pbuf%DES,cld_resnow,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_snow,,,NOTE: we are using diameter,,,,,, -?,cld_rwp,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_rain_water_path,,,,,,,,, -?,cld_rerain,in ccpp-physics/rrtmgp_sw_main.F90,,,mean_effective_radius_for_rain,,,,,,,,, -?,precip_frac,in ccpp-physics/rrtmgp_sw_main.F90,,,precipitation_fraction,,,,,,,,, -,,,,,,,,,,,,,, -aer_sw%tau,aersw_tau,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_optical_depth_for_shortwave_bands_01_16,,,,,,,,, -aer_sw%ssa,aersw_ssa,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_single_scattering_albedo_for_shortwave_bands_01_16,,,,,,,,, -aer_sw%g,aersw_g,in ccpp-physics/rrtmgp_sw_main.F90,,,aerosol_asymmetry_parameter_for_shortwave_bands_01_16,,,,,,,,, -?,solcon,in ccpp-physics/rrtmgp_sw_main.F90,,,solar_constant,,,,,,,,, -?,scmpsw,in ccpp-physics/rrtmgp_sw_main.F90,,,components_of_surface_downward_shortwave_fluxes,,,,,,,,, -flux_sw_up,fluxswUP_allsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_upward_allsky,,,,,,,,, -flux_lw_dn,fluxswDOWN_allsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_downward_allsky,,,,,,,,, -flux_sw_clr_up,fluxswUP_clrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_upward_clrsky,,,,,,,,, -flux_sw_clr_dn,fluxswDOWN_clrsky,in ccpp-physics/rrtmgp_sw_main.F90,,,RRTMGP_sw_flux_profile_downward_clrsky,,,,,,,,, -c_cld_tau?,cld_tau_sw,in ccpp-physics/rrtmgp_sw_main.F90,,,cloud_optical_depth_layers_at_0p55mu_band,,,,,,,,, -atm_optics_sw,sw_optical_props_accum,in ccpp-physics/rrtmgp_sw_main.F90,,,,,,,,,,,, -,,,,,,,,,,,,,, -No CAM equivalent,iovr,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_cloud_overlap_method_for_radiation,,,"For CAM must always be set to ""iovr_maxrand""",,,,,, -No CAM equivalent,iovr_convcld,in ccpp-physics/rrtmgp_sw_main.F90,,,NOT BEING USED IN CCPP CODE! SHOULD DELETE DURING CONVERSION!,,,,,,,,, -No CAM equivalent,iovr_max,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_maximum_cloud_overlap_method,,,,,,,,, -No CAM equivalent,iovr_maxrand,,,,control_for_maximum_random_cloud_overlap_method,,,,,,,,, -No CAM equivalent,iovr_rand,,,,control_for_random_cloud_overlap_method,,,,,,,,, -No CAM equivalent,iovr_dcorr,,,,control_for_decorrelation_length_cloud_overlap_method,,,,,,,,, -No CAM equivalent,iovr_exp,,,,control_for_exponential_cloud_overlap_method,,,,,,,,, -No CAM equivalent,iovr_exprand,,,,control_for_exponential_random_cloud_overlap_method,,,,,,,,, -No CAM equivalent,isubc_sw,in ccpp-physics/rrtmgp_sw_main.F90,,,control_for_sw_clouds_subgrid_approximation,,,For CAM must be set to integer that is not 1 or 2 (we are using a third way of seeding),,,,,, -doconvtran,,zm_conv_convtran.F90,flag,X,flag_for_tracer_transport_by_zhang_mcfarlane_deep_scheme,/,,,,,,,, -il1g,,zm_conv_convtran.F90,index,X,index_of_first_column_of_gathered_deep_convection_arrays,,,,,,,,, -il2g,,zm_conv_convtran.F90,index,X,index_of_last_column_of_gathered_deep_convection_arrays,,,,,,,,, -dqdt,ptend%q,zm_conv_convtran.F90,none,X,tendency_of_ccpp_constituents,,,,,,,,, -dpdry,fake_dpdry,zm_conv_convtran.F90,hPa,X,air_pressure_thickness_of_dry_air_for_deep_convection_for_gathered_convective_columns,,,,,,,,, -latice,physconst,zm_conv_evap.F90,J kg-1,X,latent_heat_of_fusion_of_water_at_0c,,,,,,,,, -latvap,physconst,zm_conv_evap.F90,J kg-1,X,o,,,,,,,,, -tmelt,physconst,zm_conv_evap.F90,,X,freezing_point_of_water,,,,,,,,, -cpres, cpair physconst,zm_conv_evap.F90,J kg-1 K-1,X,specific_heat_of_dry_air_at_constant_pressure,,,,,,,,, -zmconv_ke,zm namelist,zm_conv_evap.F90,1,X,tunable_evaporation_efficiency_over_ocean_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_ke_lnd,zm namelist,zm_conv_evap.F90,1,X,tunable_evaporation_efficiency_over_land_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_org,zm namelist,zm_conv_evap.F90,flag,X,flag_for_convective_organization_parameterization_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -tend_s_snwprd,,zm_conv_evap.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure_due_to_frozen_precipitation_production_due_to_deep_convection,,,,,,,,, -tend_s_snwevmlt,,zm_conv_evap.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure_due_to_evaporation_and_melting_of_frozen_precipitation_due_to_deep_convection,,,,,,,,, -"ptend%q(:,:,1)",,zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water,,,,,,,,, -ntprprd,ZMNTPRPD (outfld),zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection,,,,,,,,, -ntsnprd,ZMNTSNPD (outfld),zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_frozen_precipitation_wrt_moist_air_and_condensed_water_due_to_deep_convection,,,,,,,,, -flxprec,ZMFLXPRC (outfld),zm_conv_evap.F90,kg m-2 s-1,X,precipitation_flux_at_interface_due_to_deep_convection,,,,,,,,, -flxsnow,ZMFLXSNW (outfld),zm_conv_evap.F90,kg m-2 s-1,X,frozen_precipitation_flux_at_interface_due_to_deep_convection,,,,,,,,, -prdsnow,,zm_conv_evap.F90,kg kg-1 s-1,X,tendency_of_frozen_precipitation_wrt_moist_air_and_condensed_water_due_to_source_processes,,,,,,,,, -domomtran,,zm_conv_momtran.F90,flag,X,flag_for_momentum_transport_by_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, -momcu,zm namelist,zm_conv_momtran.F90,1,X,tunable_parameter_for_momentum_transport_by_updraft_in_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, -momcd,zm_namelist,zm_conv_momtran.F90,1,X,tunable_parameter_for_momentum_transport_by_downdraft_in_zhang_mcfarlane_deep_convection_scheme,,,separate into two variables?,,,,,, -pguallu,ZMUPGU and ZMVPGU (outfld),zm_conv_momtran.F90,m s-2,X,tendency_of_eastward_wind_due_to_zhang_mcfarlane_deep_convective_updraft_pressure_gradient_term,,,separate into two variables?,,,,,, -pguallv,,,m s-2,X,tendency_of_northward_wind_due_to_zhang_mcfarlane_deep_convective_updraft_pressure_gradient_term,,,,,,,,, -pgdallu,ZMUPGD and ZMVPGD (outfld),zm_conv_momtran.F90,m s-2,X,tendency_of_eastward_wind_due_to_zhang_mcfarlane_deep_convective_downdraft_pressure_gradient_term,,,separate into two variables?,,,,,, -pgdallv,,,m s-2,X,tendency_of_northward_wind_due_to_zhang_mcfarlane_deep_convective_downdraft_pressure_gradient_term,,,,,,,,, -icwuu,ZMICUU and ZMICVU (outfld),zm_conv_momtran.F90,m s-1,X,in_cloud_eastward_wind_in_updraft_due_to_deep_convection,X,,separate into two variables?,,,,,, -icwuv,,,m s-1,X,in_cloud_northward_wind_in_updraft_due_to_deep_convection,X,,,,,,,, -icwdu,ZMICUD and ZMICVD (outfld),zm_conv_momtran.F90,m s-1,X,in_cloud_eastward_wind_in_downdraft_due_to_deep_convection,X,,separate into two variables?,,,,,, -icwdv,,,m s-1,X,in_cloud_northward_wind_in_downdraft_due_to_deep_convection,X,,,,,,,, -seten,ptend%s,zm_conv_momtran.F90,J kg-1 s-1,X,tendency_of_dry_air_enthalpy_at_constant_pressure,X,X,Will be in ESCOMP as soon as my PR is merged; separate into two variables?,,,,,, -epsilo,physconst,zm_convr.F90,1,X,ratio_of_water_vapor_to_dry_air_molecular_weights,X,,"Need to replace ""h2o"" with ""water_vapor"" in CAM-SIMA",,,,,, -gravit,physconst,zm_convr.F90,m s-2,X,standard_gravitational_acceleration,X,X,,,,,,, -limcnv_in,top interface level limit for convection,zm_convr.F90,index,X,vertical_interface_index_of_deep_convection_height_limit,,,,,,,,, -zmconv_c0_lnd,zm namelist,zm_convr.F90,m-1?,,cloud_condensate_to_precipitation_autoconversion_coefficient_over_land_for_zhang_mcfarlane_deep_convection_scheme,,,Adam to look into units,,,,,, -zmconv_c0_ocn,zm namelist,zm_convr.F90,m-1?,,cloud_condensate_to_precipitation_autoconversion_coefficient_over_ocean_for_zhang_mcfarlane_deep_convection_scheme,,,Adam to look into units,,,,,, -zmconv_momcu,zm namelist,zm_convr.F90,1,X,momentum_transport_parameter_for_vertical_pressure_gradient_force_for_updraft_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_momcd,zm namelist,zm_convr.F90,1,X,momentum_transport_parameter_for_vertical_pressure_gradient_force_for_downdraft_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_num_cin,zm namelist,zm_convr.F90,count,X,number_of_negative_buoyancy_layers_allowed_before_convection_top_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -no_deep_pbl,"if true, no deep convection in PBL",zm_convr.F90,flag,X,flag_for_no_deep_convection_in_pbl,,,,,,,,, -zmconv_tiedke_add,convective parcel temperature perturbation,zm_convr.F90,K,X,parcel_temperature_perturbation_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_capelmt,zm namelist; triggering threhsold for ZM convection,zm_convr.F90,J kg-1,X,cape_threshold_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_dmpdz,zm namelist; parcel fractional mass entrainment rate,zm_convr.F90,m-1,X,entrainment_rate_for_cape_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_parcel_pbl,zm namelist; switch for parcel pbl calculation,zm_convr.F90,flag,X,flag_for_well_mixed_pbl_parcel_property_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -zmconv_tau,zm namelist; timesecale for convection,zm_convr.F90,s,X,deep_convective_adjustment_timescale_for_zhang_mcfarlane_deep_convection_scheme,,,,,,,,, -cpwv,physconst,zm_convr.F90,J kg-1 K-1,X,specific_heat_of_water_vapor_at_constant_pressure,,,This is what the standard name/units are in CAM-SIMA,,,,,, -cpliq,physconst,zm_convr.F90,J kg-1 K-1,X,specific_heat_of_liquid_water_at_constant_pressure,X,,,,,,,, -rh2o,physconst,zm_convr.F90,J kg-1 K-1,X,gas_constant_of_water_vapor,,,This is what the standard name/units are in CAM-SIMA,,,,,, -jctop,o row top-of-deep-convection indices passed out,zm_convr.F90,index,X,vertical_index_at_top_of_deep_convection,,,"NOTE: There may be a bug here, in that it is declared a real but appears to be dealing with integers",,,,,, -jcbot,o row of base of cloud indices passed out,zm_convr.F90,index,X,vertical_index_of_deep_convection_launch_level,,,"NOTE: There may be a bug here, in that it is declared a real but appears to be dealing with integers",,,,,, -zm,state%zm,zm_convr.F90,m,X,geopotential_height_wrt_surface,X,X,,,,,,, -geos,state%phis,zm_convr.F90,m2 s-2,X,surface_geopotential,X,X,,,,,,, -zi,state%zi,zm_convr.F90,m,X,geopotential_height_wrt_surface_at_interface,X,X,,,,,,, -pap,state%pmid,zm_convr.F90,Pa,X,air_pressure,X,X,,,,,,, -paph,state%pint,zm_convr.F90,Pa,X,air_pressure_at_interface,X,X,,,,,,, -dpp,state%pdel,zm_convr.F90,Pa,X,air_pressure_thickness,X,X,,,,,,, -delt,0.5 * timestep_for_physics,zm_convr.F90,s,X,half_timestep_for_physics,X,,"Is""0.5"" is incorrect? <- ADAM",,possible bug?,,,, -mcon,convective mass flux--m sub c,zm_convr.F90,hPa s-1,X,atmosphere_convective_mass_flux_due_to_deep_convection,,,,,,,,, -cme,cmf condensation - evaporation (is this the same as CMELIQ?),zm_convr.F90,,kg kg-1 s-1,tendency_of_water_vapor_mixing_ratio_wrt_moist_air and_condensed_water_from_cloud_condensation_minus_precipitation_evaporation_due_to_deep_convection,X,,,,,,,, -cape,w convective available potential energy,zm_convr.F90,,J kg-1,zhang_mcfarlane_convective_available_potential_energy,,,,,,,,, -org,Organization of deep convection (unitless),zm_convr.F90,1,X,zhang_mcfarlane_organization_parameter_of_deep_convection,,,,,,,,, -orgt,Single level value of organization (org) copied to the whole column (required for constituent advection),zm_convr.F90,S-1,X,tendency_of_zhang_mcfarlane_organization_parameter_of_deep_convection,,,,,,,,, -org2d,Tendency of convective organization (unitless/second),zm_convr.F90,1,X,zhang_mcfarlane_organization_parameter_of_deep_convection_copied_to_whole_column,,,,,,,,, \ No newline at end of file From 8a6478228c10d72c65c28ea6a1dc2ff69691dd31 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Thu, 27 Jun 2024 14:45:10 -0600 Subject: [PATCH 34/79] Moving input names to standard names xml generator to tools directory. --- {src/data => tools}/generate_input_to_stdnames_update.py | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {src/data => tools}/generate_input_to_stdnames_update.py (100%) diff --git a/src/data/generate_input_to_stdnames_update.py b/tools/generate_input_to_stdnames_update.py similarity index 100% rename from src/data/generate_input_to_stdnames_update.py rename to tools/generate_input_to_stdnames_update.py From dfd52b1ac6b39d606033e1b81d53a23f1a07e449 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Thu, 27 Jun 2024 15:52:02 -0600 Subject: [PATCH 35/79] Updating to latest development ccpp-framework. --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index a55849c2..4c1361ad 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -2,7 +2,7 @@ local_path = ccpp_framework protocol = git repo_url = https://github.com/peverwhee/ccpp-framework -tag = 7781d11383a2bd20d8958153ad8d857d8a09f8be +tag = CPF_0.2.057 required = True [mpas] From f63ebf25a5c0c0702a0255d437c41ea95bbbe766 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Thu, 27 Jun 2024 16:10:24 -0600 Subject: [PATCH 36/79] Removing commented code and updating standard name. --- src/dynamics/utils/hycoef.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 33817faa..33ee5a2f 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -478,10 +478,7 @@ subroutine hycoef_read(File) ! Check whether file contains value for P0. If it does then use it ierr = pio_inq_varid(file, 'P0', p0_desc) if (ierr /= PIO_NOERR) then - ierr = pio_inq_varid(File, 'reference_pressure', p0_desc) - !if (ierr /= PIO_NOERR) then - ! call endrun(routine//': reading P0') - !end if + ierr = pio_inq_varid(File, 'surface_reference_pressure', p0_desc) end if if (ierr == PIO_NOERR) then ierr = pio_get_var(file, p0_desc, ps0) From 4fd48f77ccfbfc601b7a75f22afbfeee9ecb2cf2 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Sun, 30 Jun 2024 01:19:52 -0600 Subject: [PATCH 37/79] conditionally write instantaneous file --- src/history/cam_hist_file.F90 | 109 +++++++++++++++++++--------------- 1 file changed, 60 insertions(+), 49 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 9a34f43f..448781e3 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -61,7 +61,8 @@ module cam_hist_file integer, allocatable, private :: grids(:) integer, private :: hfile_type = hfile_type_default logical, private :: collect_patch_output = PATCH_DEF - logical, private :: split_file = .false. + logical, private :: has_instantaneous = .false. + logical, private :: has_accumulated = .false. logical, private :: write_nstep0 = .false. type(interp_info_t), pointer, private :: interp_info => NULL() character(len=CL), allocatable, private :: file_names(:) @@ -103,7 +104,6 @@ module cam_hist_file procedure :: is_initial_value_file => config_init_value_file procedure :: is_satellite_file => config_satellite_file procedure :: is_hist_restart_file => config_restart_file - procedure :: is_split_file => config_is_split_file procedure :: do_write_nstep0 => config_do_write_nstep0 procedure :: file_is_setup => config_file_is_setup ! Actions @@ -343,16 +343,6 @@ end function config_restart_file ! ======================================================================== - logical function config_is_split_file(this) - ! Dummy argument - class(hist_file_t), intent(in) :: this - - config_is_split_file = this%split_file - - end function config_is_split_file - - ! ======================================================================== - logical function config_do_write_nstep0(this) ! Dummy argument class(hist_file_t), intent(in) :: this @@ -402,7 +392,7 @@ subroutine config_configure(this, volume, out_prec, max_frames, & output_freq, file_type, filename_spec, collect_patch_out, & inst_fields, avg_fields, min_fields, max_fields, var_fields, & write_nstep0, interp_out, interp_nlat, interp_nlon, interp_grid, & - interp_type, split_file) + interp_type) use shr_string_mod, only: to_lower => shr_string_toLower use string_utils, only: parse_multiplier use cam_abortutils, only: endrun, check_allocate @@ -426,14 +416,20 @@ subroutine config_configure(this, volume, out_prec, max_frames, & integer, optional, intent(in) :: interp_nlon character(len=*), optional, intent(in) :: interp_grid character(len=*), optional, intent(in) :: interp_type - logical, optional, intent(in) :: split_file ! Local variables character(len=CL) :: errmsg integer :: last_char integer :: ierr integer :: num_fields + integer :: num_inst_fields + integer :: num_avg_fields + integer :: num_min_fields + integer :: num_max_fields + integer :: num_var_fields integer :: field_index integer :: idx + logical :: has_inst + logical :: has_acc character(len=*), parameter :: subname = 'config_configure: ' call this%reset() @@ -473,12 +469,26 @@ subroutine config_configure(this, volume, out_prec, max_frames, & ! To do: write and call interp object creator end if end if - if (present(split_file) .and. split_file) then - this%split_file = .true. + + num_inst_fields = count_array(inst_fields) + num_avg_fields = count_array(avg_fields) + num_min_fields = count_array(min_fields) + num_max_fields = count_array(max_fields) + num_var_fields = count_array(var_fields) + + num_fields = num_inst_fields + num_avg_fields + num_min_fields + & + num_max_fields + num_var_fields + + if (num_inst_fields > 0) then + this%has_instantaneous = .true. + end if + + if (num_fields - num_inst_fields > 0) then + this%has_accumulated = .true. end if - num_fields = count_array(inst_fields) + count_array(avg_fields) + & - count_array(min_fields) + count_array(max_fields) + count_array(var_fields) +! num_fields = count_array(inst_fields) + count_array(avg_fields) + & +! count_array(min_fields) + count_array(max_fields) + count_array(var_fields) allocate(this%field_names(num_fields), stat=ierr) call check_allocate(ierr, subname, 'this%field_names', & file=__FILE__, line=__LINE__-1) @@ -493,27 +503,27 @@ subroutine config_configure(this, volume, out_prec, max_frames, & field_index = 1 ! Add the field names and associated accumulate types to the object - do idx = 1, count_array(inst_fields) + do idx = 1, num_inst_fields this%accumulate_types(field_index) = 'lst' this%field_names(field_index) = inst_fields(idx) field_index = field_index + 1 end do - do idx = 1, count_array(avg_fields) + do idx = 1, num_avg_fields this%accumulate_types(field_index) = 'avg' this%field_names(field_index) = avg_fields(idx) field_index = field_index + 1 end do - do idx = 1, count_array(min_fields) + do idx = 1, num_min_fields this%accumulate_types(field_index) = 'min' this%field_names(field_index) = min_fields(idx) field_index = field_index + 1 end do - do idx = 1, count_array(max_fields) + do idx = 1, num_max_fields this%accumulate_types(field_index) = 'max' this%field_names(field_index) = max_fields(idx) field_index = field_index + 1 end do - do idx = 1, count_array(var_fields) + do idx = 1, num_var_fields this%accumulate_types(field_index) = 'var' this%field_names(field_index) = var_fields(idx) field_index = field_index + 1 @@ -532,11 +542,13 @@ subroutine config_print_config(this) class(hist_file_t), intent(in) :: this if (masterproc) then - write(iulog, '(2a)') "History configuration for volume = ", & - trim(this%volume) - if (this%split_file) then - write(iulog, '(5a)') " File will be split into two; ", trim(this%volume), & - "i for instantaneous and ", trim(this%volume), "a for accumulated" + if (this%has_instantaneous) then + write(iulog, '(3a)') "Instanteous history configuration for volume = ", & + trim(this%volume), 'i' + end if + if (this%has_accumulated) then + write(iulog, '(3a)') "Accumulated history configuration for volume = ", & + trim(this%volume), 'a' end if select case(this%hfile_type) case (hfile_type_history) @@ -869,20 +881,24 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) ! Log what we're doing if (masterproc) then - if (this%is_split_file()) then - write(iulog,*)'Opening netcdf history files ', trim(this%file_names(accumulated_file_index)), & - ' ', trim(this%file_names(instantaneous_file_index)) - else - write(iulog,*) 'Opening netcdf history file ', trim(this%file_names(instantaneous_file_index)) + if (this%has_accumulated) then + write(iulog,*) 'Opening netcdf history file for accumulated output ', & + trim(this%file_names(accumulated_file_index)) + end if + if (this%has_instantaneous) then + write(iulog,*) 'Opening netcdf history file for instantaneous output', & + trim(this%file_names(instantaneous_file_index)) end if end if amode = PIO_CLOBBER - call cam_pio_createfile(this%hist_files(instantaneous_file_index), & - this%file_names(instantaneous_file_index), amode) + if (this%has_instantaneous) then + call cam_pio_createfile(this%hist_files(instantaneous_file_index), & + this%file_names(instantaneous_file_index), amode) + end if - if (this%is_split_file()) then + if (this%has_accumulated) then call cam_pio_createfile(this%hist_files(accumulated_file_index), & this%file_names(accumulated_file_index), amode) end if @@ -1330,10 +1346,12 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) num_samples = this%num_samples if (masterproc) then do split_file_index = 1, max_split_files - if (split_file_index == instantaneous_file_index) then - write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) - else if (this%split_file) then - write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) + if (pio_file_is_open(this%hist_files(split_file_index))) then + if (split_file_index == instantaneous_file_index) then + write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) + else + write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) + end if end if 200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) @@ -1636,7 +1654,6 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & integer :: num_fields_var integer :: file_type integer :: rl_kind - logical :: has_acc ! XXgoldyXX: Add patch information logical :: hist_interp_out integer :: hist_interp_nlat @@ -1674,7 +1691,6 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_filename_spec = UNSET_C hist_write_nstep0 = .false. - has_acc = .false. ! Read namelist entry if (masterproc) then read(unitn, hist_file_config_nl, iostat=ierr) @@ -1726,28 +1742,24 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & if (num_fields_avg > 0) then call endrun(subname//"ERROR, average fields not yet implemented", & file=__FILE__, line=__LINE__) - has_acc = .true. call MPI_Bcast(hist_avg_fields(:), num_fields_avg, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_min > 0) then call endrun(subname//"ERROR, minimum fields not yet implemented", & file=__FILE__, line=__LINE__) - has_acc = .true. call MPI_Bcast(hist_min_fields(:), num_fields_min, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_max > 0) then call endrun(subname//"ERROR, maximum fields not yet implemented", & file=__FILE__, line=__LINE__) - has_acc = .true. call MPI_Bcast(hist_max_fields(:), num_fields_max, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_var > 0) then call endrun(subname//"ERROR, standard deviation fields not yet implemented", & file=__FILE__, line=__LINE__) - has_acc = .true. call MPI_Bcast(hist_var_fields(:), num_fields_var, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if @@ -1773,10 +1785,9 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & hist_output_frequency, file_type, hist_filename_spec, & hist_collect_patch_output, hist_inst_fields, hist_avg_fields, & hist_min_fields, hist_max_fields, hist_var_fields, & - hist_write_nstep0, interp_out=hist_interp_out, & + hist_write_nstep0, interp_out=hist_interp_out, & interp_nlat=hist_interp_nlat, interp_nlon=hist_interp_nlon, & - interp_grid=hist_interp_grid, interp_type=hist_interp_type, & - split_file=has_acc) + interp_grid=hist_interp_grid, interp_type=hist_interp_type) call hfile_config%print_config() end subroutine read_namelist_entry From 330509ed37e811c315a67d9672a395cc36663145 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Sun, 30 Jun 2024 18:20:46 -0600 Subject: [PATCH 38/79] grid support clean-up --- src/utils/cam_grid_support.F90 | 8746 ++++++++++++++++---------------- 1 file changed, 4436 insertions(+), 4310 deletions(-) diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index ec032bea..0526c7f2 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -1,4460 +1,4586 @@ module cam_grid_support - use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4, max_chars=>shr_kind_cl - use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4 - use shr_sys_mod, only: shr_sys_flush - use pio, only: iMap=>PIO_OFFSET_KIND, var_desc_t - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use spmd_utils, only: masterproc - use cam_pio_utils, only: cam_pio_handle_error - use cam_map_utils, only: cam_filemap_t - - implicit none - private - - public iMap - - integer, parameter, public :: max_hcoordname_len = 16 - integer, parameter, public :: max_split_files = 2 - - type, public :: vardesc_ptr_t - type(var_desc_t), pointer :: p => NULL() - end type vardesc_ptr_t - !--------------------------------------------------------------------------- - ! - ! horiz_coord_t: Information for horizontal dimension attributes - ! - !--------------------------------------------------------------------------- - type, public :: horiz_coord_t - private - character(len=max_hcoordname_len) :: name = '' ! coordinate name - character(len=max_hcoordname_len) :: dimname = '' ! dimension name - ! NB: If dimname is blank, it is assumed to be name - integer :: dimsize = 0 ! global size of dimension - character(len=max_chars) :: long_name = '' ! 'long_name' attribute - character(len=max_chars) :: units = '' ! 'units' attribute - real(r8), pointer :: values(:) => NULL() ! dim values (local if map) - integer(iMap), pointer :: map(:) => NULL() ! map (dof) for dist. coord - logical :: latitude ! .false. means longitude - real(r8), pointer :: bnds(:,:) => NULL() ! bounds, if present - type(vardesc_ptr_t) :: vardesc(max_split_files) ! If we are to write coord - type(vardesc_ptr_t) :: bndsvdesc(max_split_files) ! If we are to write bounds - contains - procedure :: get_coord_len => horiz_coord_len - procedure :: num_elem => horiz_coord_num_elem - procedure :: global_size => horiz_coord_find_size - procedure :: get_coord_name => horiz_coord_name - procedure :: get_dim_name => horiz_coord_dim_name - procedure :: get_long_name => horiz_coord_long_name - procedure :: get_units => horiz_coord_units - procedure :: write_attr => write_horiz_coord_attr - procedure :: write_var => write_horiz_coord_var - end type horiz_coord_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_t: Auxiliary quantity for a CAM grid - ! - !--------------------------------------------------------------------------- - type, abstract :: cam_grid_attribute_t - character(len=max_hcoordname_len) :: name = '' ! attribute name - character(len=max_chars) :: long_name = '' ! attribute long_name - type(vardesc_ptr_t) :: vardesc(max_split_files) -! We aren't going to use this until we sort out PGI issues - class(cam_grid_attribute_t), pointer :: next => NULL() - contains - procedure :: cam_grid_attr_init - procedure(write_cam_grid_attr), deferred :: write_attr - procedure(write_cam_grid_attr), deferred :: write_val - procedure(print_attr_spec), deferred :: print_attr - procedure :: print_attr_base - end type cam_grid_attribute_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_0d_int_t: Global integral attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_int_t - integer :: ival - contains - procedure :: cam_grid_attr_init_0d_int - procedure :: write_attr => write_cam_grid_attr_0d_int - procedure :: write_val => write_cam_grid_val_0d_int - procedure :: print_attr => print_attr_0d_int - end type cam_grid_attribute_0d_int_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_0d_char_t: Global string attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_char_t - character(len=max_chars) :: val - contains - procedure :: cam_grid_attr_init_0d_char - procedure :: write_attr => write_cam_grid_attr_0d_char - procedure :: write_val => write_cam_grid_val_0d_char - procedure :: print_attr => print_attr_0d_char - end type cam_grid_attribute_0d_char_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_1d_int_t: 1-d integer attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_int_t - character(len=max_hcoordname_len) :: dimname ! attribute dimension - integer :: dimsize ! Global array/map size - integer, pointer :: values(:) => NULL() - integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O - contains - procedure :: cam_grid_attr_init_1d_int - procedure :: write_attr => write_cam_grid_attr_1d_int - procedure :: write_val => write_cam_grid_val_1d_int - procedure :: print_attr => print_attr_1d_int - end type cam_grid_attribute_1d_int_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_1d_r8_t: 1-d real*8 attribute - ! - !--------------------------------------------------------------------------- - type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_r8_t - character(len=max_hcoordname_len) :: dimname ! attribute dimension - integer :: dimsize ! Global array/map size - real(r8), pointer :: values(:) => NULL() - integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O - contains - procedure :: cam_grid_attr_init_1d_r8 - procedure :: write_attr => write_cam_grid_attr_1d_r8 - procedure :: write_val => write_cam_grid_val_1d_r8 - procedure :: print_attr => print_attr_1d_r8 - end type cam_grid_attribute_1d_r8_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attr_ptr_t: linked list of CAM grid attributes - ! - !--------------------------------------------------------------------------- - type :: cam_grid_attr_ptr_t - private - class(cam_grid_attribute_t), pointer :: attr => NULL() - type(cam_grid_attr_ptr_t), pointer :: next => NULL() - contains - private - procedure, public :: initialize => initializeAttrPtr - procedure, public :: getAttr => getAttrPtrAttr - procedure, public :: getNext => getAttrPtrNext - procedure, public :: setNext => setAttrPtrNext - end type cam_grid_attr_ptr_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_t: Information for a CAM grid (defined by a dycore) - ! - !--------------------------------------------------------------------------- - type :: cam_grid_t - character(len=max_hcoordname_len) :: name = '' ! grid name - integer :: id ! e.g., dyn_decomp - type(horiz_coord_t), pointer :: lat_coord => NULL() ! Latitude coord - type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude coord - logical :: unstructured ! Is this needed? - logical :: block_indexed ! .false. for lon/lat - logical :: attrs_defined(2) = .false. - logical :: zonal_grid = .false. - type(cam_filemap_t), pointer :: map => null() ! global dim map (dof) - type(cam_grid_attr_ptr_t), pointer :: attributes => NULL() - contains - procedure :: print_cam_grid - procedure :: is_unstructured => cam_grid_unstructured - procedure :: is_block_indexed => cam_grid_block_indexed - procedure :: is_zonal_grid => cam_grid_zonal_grid - procedure :: coord_lengths => cam_grid_get_dims - procedure :: coord_names => cam_grid_coord_names - procedure :: dim_names => cam_grid_dim_names - procedure :: num_elem => cam_grid_local_size - procedure :: set_map => cam_grid_set_map - procedure :: get_patch_mask => cam_grid_get_patch_mask - procedure :: get_lon_lat => cam_grid_get_lon_lat - procedure :: find_src_dims => cam_grid_find_src_dims - procedure :: find_dest_dims => cam_grid_find_dest_dims - procedure :: find_dimids => cam_grid_find_dimids - procedure :: get_decomp => cam_grid_get_pio_decomp - procedure :: read_darray_2d_int => cam_grid_read_darray_2d_int - procedure :: read_darray_3d_int => cam_grid_read_darray_3d_int - procedure :: read_darray_2d_double => cam_grid_read_darray_2d_double - procedure :: read_darray_3d_double => cam_grid_read_darray_3d_double - procedure :: read_darray_2d_real => cam_grid_read_darray_2d_real - procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real - procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int - procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int - procedure :: write_darray_1d_double => cam_grid_write_darray_1d_double - procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double - procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double - procedure :: write_darray_1d_real => cam_grid_write_darray_1d_real - procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real - procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real - end type cam_grid_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_patch_t: Information for a patch of a CAM grid - ! - !--------------------------------------------------------------------------- - type, public :: cam_grid_patch_t - private - integer :: grid_id = -1 ! grid containing patch points - integer :: global_size = 0 ! var patch dim size - integer :: global_lat_size = 0 ! lat patch dim size - integer :: global_lon_size = 0 ! lon patch dim size - integer :: num_points = 0 ! task-local size - real(r8) :: lon_range(2) - real(r8) :: lat_range(2) - logical :: collected_columns ! Output unstructured - type(cam_filemap_t), pointer :: mask => null() ! map for active pts - integer(iMap), pointer :: latmap(:) => null() ! map for patch coords - integer(iMap), pointer :: lonmap(:) => null() ! map for patch coords - real(r8), pointer :: lonvals(:) => null() ! For collected output - real(r8), pointer :: latvals(:) => null() ! For collected output - contains - procedure :: gridid => cam_grid_patch_get_id - procedure :: get_axis_names => cam_grid_patch_get_axis_names - procedure :: get_coord_long_name => cam_grid_patch_get_coord_long_name - procedure :: get_coord_units => cam_grid_patch_get_coord_units - procedure :: set_patch => cam_grid_patch_set_patch - procedure :: get_decomp => cam_grid_patch_get_decomp - procedure :: compact => cam_grid_patch_compact - procedure :: active_cols => cam_grid_patch_get_active_cols - procedure :: write_coord_vals => cam_grid_patch_write_vals - procedure :: grid_index => cam_grid_patch_get_grid_index - procedure :: deallocate => cam_grid_patch_deallocate -!!XXgoldyXX: PGI workaround? -! COMPILER_BUG(goldy, 2014-11-28, pgi <= 14.9); Commented code should work -! procedure :: global_size_map => cam_grid_patch_get_global_size_map -! procedure :: global_size_axes => cam_grid_patch_get_global_size_axes -! generic :: get_global_size => global_size_map, global_size_axes - procedure :: cam_grid_patch_get_global_size_map - procedure :: cam_grid_patch_get_global_size_axes - generic :: get_global_size => cam_grid_patch_get_global_size_map, cam_grid_patch_get_global_size_axes - end type cam_grid_patch_t - - !--------------------------------------------------------------------------- - ! - ! cam_grid_header_info_t: Hold NetCDF dimension information for a CAM grid - ! - !--------------------------------------------------------------------------- - type, public :: cam_grid_header_info_t - private - integer :: grid_id = -1 ! e.g., dyn_decomp - integer, allocatable :: hdims(:) ! horizontal dimension ids - type(var_desc_t), pointer :: lon_varid => NULL() ! lon coord variable - type(var_desc_t), pointer :: lat_varid => NULL() ! lat coord variable - contains - procedure :: get_gridid => cam_grid_header_info_get_gridid - procedure :: set_gridid => cam_grid_header_info_set_gridid - procedure :: set_hdims => cam_grid_header_info_set_hdims - procedure :: num_hdims => cam_grid_header_info_num_hdims - procedure :: get_hdimid => cam_grid_header_info_hdim - !!XXgoldyXX: Maybe replace this with horiz_coords for patches? - procedure :: set_varids => cam_grid_header_info_set_varids - procedure :: get_lon_varid => cam_grid_header_info_lon_varid - procedure :: get_lat_varid => cam_grid_header_info_lat_varid - procedure :: deallocate => cam_grid_header_info_deallocate - end type cam_grid_header_info_t - - !--------------------------------------------------------------------------- - ! - ! END: types BEGIN: interfaces for types - ! - !--------------------------------------------------------------------------- - - ! Abstract interface for write_attr procedure of cam_grid_attribute_t class - ! NB: This will not compile on some pre-13 Intel compilers - ! (fails on 12.1.0.233 on Frankfurt, passes on 13.0.1.117 on Yellowstone) - abstract interface - subroutine write_cam_grid_attr(attr, File, file_index) + use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4 + use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4 + use shr_kind_mod, only: max_chars=>shr_kind_cl + use shr_sys_mod, only: shr_sys_flush + use cam_map_utils, only: iMap + use pio, only: var_desc_t + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use cam_pio_utils, only: cam_pio_handle_error + use cam_map_utils, only: cam_filemap_t + + implicit none + private + + integer, parameter, public :: max_hcoordname_len = 16 + integer, parameter, public :: max_split_files = 2 + + type, public :: vardesc_ptr_t + type(var_desc_t), pointer :: p => NULL() + end type vardesc_ptr_t + + real(r8), parameter :: grid_fill_value = -900.0_r8 + + !--------------------------------------------------------------------------- + ! + ! horiz_coord_t: Information for horizontal dimension attributes + ! + !--------------------------------------------------------------------------- + type, public :: horiz_coord_t + private + character(len=max_hcoordname_len) :: name = '' ! coordinate name + character(len=max_hcoordname_len) :: dimname = '' ! dimension name + ! NB: If dimname is blank, it is assumed to be name + integer :: dimsize = 0 ! global size of dimension + character(len=max_chars) :: long_name = '' ! 'long_name' attribute + character(len=max_chars) :: units = '' ! 'units' attribute + real(r8), pointer :: values(:) => NULL() ! dim vals (local if map) + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for dist. coord + logical :: latitude ! .false. means longitude + real(r8), pointer :: bnds(:,:) => NULL() ! bounds, if present + type(vardesc_ptr_t) :: vardesc(max_split_files) ! If we are to write coord + type(vardesc_ptr_t) :: bndsvdesc(max_split_files) ! Set to write bounds + contains + procedure :: get_coord_len => horiz_coord_len + procedure :: num_elem => horiz_coord_num_elem + procedure :: global_size => horiz_coord_find_size + procedure :: get_coord_name => horiz_coord_name + procedure :: get_dim_name => horiz_coord_dim_name + procedure :: get_long_name => horiz_coord_long_name + procedure :: get_units => horiz_coord_units + procedure :: write_attr => write_horiz_coord_attr + procedure :: write_var => write_horiz_coord_var + end type horiz_coord_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_t: Auxiliary quantity for a CAM grid + ! + !--------------------------------------------------------------------------- + type, abstract :: cam_grid_attribute_t + character(len=max_hcoordname_len) :: name = '' ! attribute name + character(len=max_chars) :: long_name = '' ! attr long_name + type(vardesc_ptr_t) :: vardesc(max_split_files) + ! We aren't going to use this until we sort out PGI issues + class(cam_grid_attribute_t), pointer :: next => NULL() + contains + procedure :: cam_grid_attr_init + procedure(write_cam_grid_attr), deferred :: write_attr + procedure(write_cam_grid_attr), deferred :: write_val + procedure(print_attr_spec), deferred :: print_attr + procedure :: print_attr_base + end type cam_grid_attribute_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_0d_int_t: Global integral attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_int_t + integer :: ival + contains + procedure :: cam_grid_attr_init_0d_int + procedure :: write_attr => write_cam_grid_attr_0d_int + procedure :: write_val => write_cam_grid_val_0d_int + procedure :: print_attr => print_attr_0d_int + end type cam_grid_attribute_0d_int_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_0d_char_t: Global string attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_0d_char_t + character(len=max_chars) :: val + contains + procedure :: cam_grid_attr_init_0d_char + procedure :: write_attr => write_cam_grid_attr_0d_char + procedure :: write_val => write_cam_grid_val_0d_char + procedure :: print_attr => print_attr_0d_char + end type cam_grid_attribute_0d_char_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_1d_int_t: 1-d integer attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_int_t + character(len=max_hcoordname_len) :: dimname ! attribute dimension + integer :: dimsize ! Global array/map size + integer, pointer :: values(:) => NULL() + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O + contains + procedure :: cam_grid_attr_init_1d_int + procedure :: write_attr => write_cam_grid_attr_1d_int + procedure :: write_val => write_cam_grid_val_1d_int + procedure :: print_attr => print_attr_1d_int + end type cam_grid_attribute_1d_int_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attribute_1d_r8_t: 1-d real*8 attribute + ! + !--------------------------------------------------------------------------- + type, extends(cam_grid_attribute_t) :: cam_grid_attribute_1d_r8_t + character(len=max_hcoordname_len) :: dimname ! attribute dimension + integer :: dimsize ! Global array/map size + real(r8), pointer :: values(:) => NULL() + integer(iMap), pointer :: map(:) => NULL() ! map (dof) for I/O + contains + procedure :: cam_grid_attr_init_1d_r8 + procedure :: write_attr => write_cam_grid_attr_1d_r8 + procedure :: write_val => write_cam_grid_val_1d_r8 + procedure :: print_attr => print_attr_1d_r8 + end type cam_grid_attribute_1d_r8_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_attr_ptr_t: linked list of CAM grid attributes + ! + !--------------------------------------------------------------------------- + type :: cam_grid_attr_ptr_t + private + class(cam_grid_attribute_t), pointer :: attr => NULL() + type(cam_grid_attr_ptr_t), pointer :: next => NULL() + contains + private + procedure, public :: initialize => initializeAttrPtr + procedure, public :: getAttr => getAttrPtrAttr + procedure, public :: getNext => getAttrPtrNext + procedure, public :: setNext => setAttrPtrNext + end type cam_grid_attr_ptr_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_t: Information for a CAM grid (defined by a dycore) + ! + !--------------------------------------------------------------------------- + type :: cam_grid_t + character(len=max_hcoordname_len) :: name = '' ! grid name + integer :: id ! e.g., dyn_decomp + type(horiz_coord_t), pointer :: lat_coord => NULL() ! Latitude + type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude + logical :: unstructured ! Is this needed? + logical :: block_indexed ! .false. for lon/lat + logical :: attrs_defined(2) = .false. + logical :: zonal_grid = .false. + type(cam_filemap_t), pointer :: map => null() ! global dim map (dof) + type(cam_grid_attr_ptr_t), pointer :: attributes => NULL() + contains + procedure :: print_cam_grid + procedure :: is_unstructured => cam_grid_unstructured + procedure :: is_block_indexed => cam_grid_block_indexed + procedure :: is_zonal_grid => cam_grid_zonal_grid + procedure :: coord_lengths => cam_grid_get_dims + procedure :: coord_names => cam_grid_coord_names + procedure :: dim_names => cam_grid_dim_names + procedure :: num_elem => cam_grid_local_size + procedure :: set_map => cam_grid_set_map + procedure :: get_patch_mask => cam_grid_get_patch_mask + procedure :: get_lon_lat => cam_grid_get_lon_lat + procedure :: find_src_dims => cam_grid_find_src_dims + procedure :: find_dest_dims => cam_grid_find_dest_dims + procedure :: find_dimids => cam_grid_find_dimids + procedure :: get_decomp => cam_grid_get_pio_decomp + procedure :: read_darray_2d_int => cam_grid_read_darray_2d_int + procedure :: read_darray_3d_int => cam_grid_read_darray_3d_int + procedure :: read_darray_2d_double => cam_grid_read_darray_2d_double + procedure :: read_darray_3d_double => cam_grid_read_darray_3d_double + procedure :: read_darray_2d_real => cam_grid_read_darray_2d_real + procedure :: read_darray_3d_real => cam_grid_read_darray_3d_real + procedure :: write_darray_2d_int => cam_grid_write_darray_2d_int + procedure :: write_darray_3d_int => cam_grid_write_darray_3d_int + procedure :: write_darray_1d_double => cam_grid_write_darray_1d_double + procedure :: write_darray_2d_double => cam_grid_write_darray_2d_double + procedure :: write_darray_3d_double => cam_grid_write_darray_3d_double + procedure :: write_darray_1d_real => cam_grid_write_darray_1d_real + procedure :: write_darray_2d_real => cam_grid_write_darray_2d_real + procedure :: write_darray_3d_real => cam_grid_write_darray_3d_real + end type cam_grid_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_patch_t: Information for a patch of a CAM grid + ! + !--------------------------------------------------------------------------- + type, public :: cam_grid_patch_t + private + integer :: grid_id = -1 ! grid with patch points + integer :: global_size = 0 ! var patch dim size + integer :: global_lat_size = 0 ! lat patch dim size + integer :: global_lon_size = 0 ! lon patch dim size + integer :: num_points = 0 ! task-local size + real(r8) :: lon_range(2) + real(r8) :: lat_range(2) + logical :: collected_columns ! Output unstructured + type(cam_filemap_t), pointer :: mask => null() ! map for active pts + integer(iMap), pointer :: latmap(:) => null() ! map for patch coords + integer(iMap), pointer :: lonmap(:) => null() ! map for patch coords + real(r8), pointer :: lonvals(:) => null() ! For collected output + real(r8), pointer :: latvals(:) => null() ! For collected output + contains + procedure :: gridid => cam_grid_patch_get_id + procedure :: get_axis_names => cam_grid_patch_get_axis_names + procedure :: get_coord_long_name => cam_grid_patch_get_coord_long_name + procedure :: get_coord_units => cam_grid_patch_get_coord_units + procedure :: set_patch => cam_grid_patch_set_patch + procedure :: get_decomp => cam_grid_patch_get_decomp + procedure :: compact => cam_grid_patch_compact + procedure :: active_cols => cam_grid_patch_get_active_cols + procedure :: write_coord_vals => cam_grid_patch_write_vals + procedure :: grid_index => cam_grid_patch_get_grid_index + procedure :: deallocate => cam_grid_patch_deallocate + !!XXgoldyXX: PGI workaround? + ! COMPILER_BUG(goldy, 2014-11-28, pgi <= 14.9); Commented code should work + ! procedure :: global_size_map => cam_grid_patch_get_global_size_map + ! procedure :: global_size_axes => cam_grid_patch_get_global_size_axes + ! generic :: get_global_size => global_size_map, global_size_axes + procedure :: cam_grid_patch_get_global_size_map + procedure :: cam_grid_patch_get_global_size_axes + generic :: get_global_size => cam_grid_patch_get_global_size_map, cam_grid_patch_get_global_size_axes + end type cam_grid_patch_t + + !--------------------------------------------------------------------------- + ! + ! cam_grid_header_info_t: Hold NetCDF dimension information for a CAM grid + ! + !--------------------------------------------------------------------------- + type, public :: cam_grid_header_info_t + private + integer :: grid_id = -1 ! e.g., dyn_decomp + integer, allocatable :: hdims(:) ! horizontal dimension ids + type(var_desc_t), pointer :: lon_varid => NULL() ! lon coord variable + type(var_desc_t), pointer :: lat_varid => NULL() ! lat coord variable + contains + procedure :: get_gridid => cam_grid_header_info_get_gridid + procedure :: set_gridid => cam_grid_header_info_set_gridid + procedure :: set_hdims => cam_grid_header_info_set_hdims + procedure :: num_hdims => cam_grid_header_info_num_hdims + procedure :: get_hdimid => cam_grid_header_info_hdim + !!XXgoldyXX: Maybe replace this with horiz_coords for patches? + procedure :: set_varids => cam_grid_header_info_set_varids + procedure :: get_lon_varid => cam_grid_header_info_lon_varid + procedure :: get_lat_varid => cam_grid_header_info_lat_varid + procedure :: deallocate => cam_grid_header_info_deallocate + end type cam_grid_header_info_t + + !--------------------------------------------------------------------------- + ! + ! END: types BEGIN: interfaces for types + ! + !--------------------------------------------------------------------------- + + ! Abstract interface for write_attr procedure of cam_grid_attribute_t class + ! NB: This will not compile on some pre-13 Intel compilers + ! (fails on 12.1.0.233 on Frankfurt, passes on 13.0.1.117 on Yellowstone) + abstract interface + subroutine write_cam_grid_attr(attr, File, file_index) + use pio, only: file_desc_t + import :: cam_grid_attribute_t + ! Dummy arguments + class(cam_grid_attribute_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + end subroutine write_cam_grid_attr + end interface + + ! Abstract interface for print_attr procedure of cam_grid_attribute_t class + abstract interface + subroutine print_attr_spec(this) + import :: cam_grid_attribute_t + ! Dummy arguments + class(cam_grid_attribute_t), intent(in) :: this + end subroutine print_attr_spec + end interface + + !! Grid variables + integer, parameter :: maxhgrids = 16 ! arbitrary limit + integer, save :: registeredhgrids = 0 + type(cam_grid_t), save :: cam_grids(maxhgrids) + + public :: horiz_coord_create + + ! Setup and I/O functions for grids rely on the grid's ID, not its index. + public :: cam_grid_register, cam_grid_attribute_register + public :: cam_grid_attribute_copy + public :: cam_grid_write_attr, cam_grid_write_var + public :: cam_grid_read_dist_array, cam_grid_write_dist_array + ! Access functions for grids rely on the grid's ID or name, not its index. + public :: cam_grid_dimensions, cam_grid_num_grids + public :: cam_grid_check ! T/F if grid ID exists + public :: cam_grid_id ! Grid ID (decomp) or -1 if error + public :: cam_grid_get_local_size + public :: cam_grid_get_file_dimids + public :: cam_grid_get_decomp + public :: cam_grid_get_gcid + public :: cam_grid_get_array_bounds + public :: cam_grid_get_coord_names, cam_grid_get_dim_names + public :: cam_grid_has_blocksize, cam_grid_get_block_count + public :: cam_grid_get_latvals, cam_grid_get_lonvals + public :: cam_grid_get_coords + public :: cam_grid_is_unstructured, cam_grid_is_block_indexed + public :: cam_grid_attr_exists + public :: cam_grid_is_zonal + ! Functions for dealing with patch masks + public :: cam_grid_compute_patch + + interface cam_grid_attribute_register + module procedure add_cam_grid_attribute_0d_int + module procedure add_cam_grid_attribute_0d_char + module procedure add_cam_grid_attribute_1d_int + module procedure add_cam_grid_attribute_1d_r8 + end interface cam_grid_attribute_register + + interface cam_grid_dimensions + module procedure cam_grid_dimensions_id + module procedure cam_grid_dimensions_name + end interface cam_grid_dimensions + + interface cam_grid_get_dim_names + module procedure cam_grid_get_dim_names_id + module procedure cam_grid_get_dim_names_name + end interface cam_grid_get_dim_names + + interface cam_grid_read_dist_array + module procedure cam_grid_read_dist_array_2d_int + module procedure cam_grid_read_dist_array_3d_int + module procedure cam_grid_read_dist_array_2d_double + module procedure cam_grid_read_dist_array_3d_double + module procedure cam_grid_read_dist_array_2d_real + module procedure cam_grid_read_dist_array_3d_real + end interface cam_grid_read_dist_array + + interface cam_grid_write_dist_array + module procedure cam_grid_write_dist_array_2d_int + module procedure cam_grid_write_dist_array_3d_int + module procedure cam_grid_write_dist_array_1d_double + module procedure cam_grid_write_dist_array_2d_double + module procedure cam_grid_write_dist_array_3d_double + module procedure cam_grid_write_dist_array_1d_real + module procedure cam_grid_write_dist_array_2d_real + module procedure cam_grid_write_dist_array_3d_real + end interface cam_grid_write_dist_array + + ! Private interfaces + interface get_cam_grid_index + module procedure get_cam_grid_index_char ! For lookup by name + module procedure get_cam_grid_index_int ! For lookup by ID + end interface get_cam_grid_index + +contains + + !!####################################################################### + !! + !! Horizontal coordinate functions + !! + !!####################################################################### + + integer function horiz_coord_find_size(this, dimname) result(dimsize) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(in) :: dimname + + dimsize = -1 + if (len_trim(this%dimname) == 0) then + if(trim(dimname) == trim(this%name)) then + dimsize = this%dimsize + end if + else + if(trim(dimname) == trim(this%dimname)) then + dimsize = this%dimsize + end if + end if + + end function horiz_coord_find_size + + integer function horiz_coord_num_elem(this) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + + if (associated(this%values)) then + horiz_coord_num_elem = size(this%values) + else + horiz_coord_num_elem = 0 + end if + + end function horiz_coord_num_elem + + subroutine horiz_coord_len(this, clen) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + integer, intent(out) :: clen + + clen = this%dimsize + end subroutine horiz_coord_len + + subroutine horiz_coord_name(this, name) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: name + + if (len(name) < len_trim(this%name)) then + call endrun('horiz_coord_name: input name too short') + end if + name = trim(this%name) + end subroutine horiz_coord_name + + subroutine horiz_coord_dim_name(this, dimname) + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: dimname + + if (len_trim(this%dimname) > 0) then + ! We have a separate dimension name (e.g., ncol) + if (len(dimname) < len_trim(this%dimname)) then + call endrun('horiz_coord_dimname: input name too short') + end if + dimname = trim(this%dimname) + else + ! No dimension name so we use the coordinate's name + ! i.e., The dimension name is the same as the coordinate variable + if (len(dimname) < len_trim(this%name)) then + call endrun('horiz_coord_dimname: input name too short') + end if + dimname = trim(this%name) + end if + end subroutine horiz_coord_dim_name + + subroutine horiz_coord_long_name(this, name) + + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: name + + if (len(name) < len_trim(this%long_name)) then + call endrun('horiz_coord_long_name: input name too short') + else + name = trim(this%long_name) + end if + + end subroutine horiz_coord_long_name + + subroutine horiz_coord_units(this, units) + + ! Dummy arguments + class(horiz_coord_t), intent(in) :: this + character(len=*), intent(out) :: units + + if (len(units) < len_trim(this%units)) then + call endrun('horiz_coord_units: input units too short') + else + units = trim(this%units) + end if + + end subroutine horiz_coord_units + + function horiz_coord_create(name, dimname, dimsize, long_name, units, & + lbound, ubound, values, map, bnds) result(newcoord) + + ! Dummy arguments + character(len=*), intent(in) :: name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + ! NB: Sure, pointers would have made sense but . . . PGI + integer, intent(in) :: lbound + integer, intent(in) :: ubound + real(r8), intent(in) :: values(lbound:ubound) + integer(iMap), intent(in), optional :: map(ubound-lbound+1) + real(r8), intent(in), optional :: bnds(2,lbound:ubound) + type(horiz_coord_t), pointer :: newcoord + + allocate(newcoord) + + newcoord%name = trim(name) + newcoord%dimname = trim(dimname) + newcoord%dimsize = dimsize + newcoord%long_name = trim(long_name) + newcoord%units = trim(units) + ! Figure out if this is a latitude or a longitude using CF standard + ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#latitude-coordinate + ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#longitude-coordinate + if ( (trim(units) == 'degrees_north') .or. & + (trim(units) == 'degree_north') .or. & + (trim(units) == 'degree_N') .or. & + (trim(units) == 'degrees_N') .or. & + (trim(units) == 'degreeN') .or. & + (trim(units) == 'degreesN')) then + newcoord%latitude = .true. + else if ((trim(units) == 'degrees_east') .or. & + (trim(units) == 'degree_east') .or. & + (trim(units) == 'degree_E') .or. & + (trim(units) == 'degrees_E') .or. & + (trim(units) == 'degreeE') .or. & + (trim(units) == 'degreesE')) then + newcoord%latitude = .false. + else + call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'") + end if + allocate(newcoord%values(lbound:ubound)) + if (ubound >= lbound) then + newcoord%values(:) = values(:) + end if + + if (present(map)) then + if (ANY(map < 0)) then + call endrun("horiz_coord_create "//trim(name)//": map vals < 0") + end if + allocate(newcoord%map(ubound - lbound + 1)) + if (ubound >= lbound) then + newcoord%map(:) = map(:) + end if + else + nullify(newcoord%map) + end if + + if (present(bnds)) then + allocate(newcoord%bnds(2, lbound:ubound)) + if (ubound >= lbound) then + newcoord%bnds = bnds + end if + else + nullify(newcoord%bnds) + end if + + end function horiz_coord_create + + !------------------------------------------------------------------------ + ! + ! write_horiz_coord_attr + ! + ! Write the dimension and coordinate attributes for a horizontal grid + ! coordinate. + ! + !------------------------------------------------------------------------ + + subroutine write_horiz_coord_attr(this, File, dimid_out, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double + use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid + use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var + + ! Dummy arguments + class(horiz_coord_t), intent(inout) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(out) :: dimid_out + integer, optional, intent(in) :: file_index + + ! Local variables + type(var_desc_t) :: vardesc + character(len=max_hcoordname_len) :: dimname + integer :: dimid ! PIO dimension ID + integer :: bnds_dimid ! PIO dim for bounds + integer :: err_handling + integer :: ierr + integer :: file_index_loc + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Make sure the dimension exists in the file + call this%get_dim_name(dimname) + call cam_pio_def_dim(File, trim(dimname), this%dimsize, dimid, & + existOK=.true.) + ! Should we define the variable? + ierr = pio_inq_varid(File, trim(this%name), vardesc) + if (ierr /= PIO_NOERR) then + ! Variable not already defined, we need to define the variable + if (associated(this%vardesc(file_index_loc)%p)) then + ! This should not happen (i.e., internal error) + call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname)) + end if + allocate(this%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(this%name), pio_double, & + (/ dimid /), this%vardesc(file_index_loc)%p, existOK=.false.) + ierr= pio_put_att(File, this%vardesc(file_index_loc)%p, & + '_FillValue', grid_fill_value) + call cam_pio_handle_error(ierr, & + 'Error writing "_FillValue" attr in write_horiz_coord_attr') + ! long_name + ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'long_name', & + trim(this%long_name)) + call cam_pio_handle_error(ierr, & + 'Error writing "long_name" attr in write_horiz_coord_attr') + ! units + ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'units', & + trim(this%units)) + call cam_pio_handle_error(ierr, & + 'Error writing "units" attr in write_horiz_coord_attr') + ! Take care of bounds if they exist + if (associated(this%bnds)) then + allocate(this%bndsvdesc(file_index_loc)%p) + ierr = pio_put_att(File, this%vardesc(file_index_loc)%p, 'bounds',& + trim(this%name)//'_bnds') + call cam_pio_handle_error(ierr, & + 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr') + call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.) + call cam_pio_def_var(File, & + trim(this%name)//'_bnds', pio_double, & + (/ bnds_dimid, dimid /), this%bndsvdesc(file_index_loc)%p, & + existOK=.false.) + call cam_pio_handle_error(ierr, & + 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr') + ! long_name + ierr = pio_put_att(File, this%bndsvdesc(file_index_loc)%p, & + 'long_name', trim(this%name)//' bounds') + call cam_pio_handle_error(ierr, & + 'Error writing bounds "long_name" attr in write_horiz_coord_attr') + ! fill value + ierr = pio_put_att(File, this%vardesc(file_index_loc)%p, & + '_FillValue', grid_fill_value) + call cam_pio_handle_error(ierr, & + 'Error writing "_FillValue" attr in write_horiz_coord_attr') + ! units + ierr = pio_put_att(File, this%bndsvdesc(file_index_loc)%p, & + 'units', trim(this%units)) + call cam_pio_handle_error(ierr, & + 'Error writing bounds "units" attr in write_horiz_coord_attr') + end if ! There are bounds for this coordinate + end if ! We define the variable + + if (present(dimid_out)) then + dimid_out = dimid + end if + + ! Back to old error handling + call pio_seterrorhandling(File, err_handling) + + end subroutine write_horiz_coord_attr + + !------------------------------------------------------------------------ + ! + ! write_horiz_coord_var + ! + ! Write the coordinate values for this coordinate + ! + !------------------------------------------------------------------------ + + subroutine write_horiz_coord_var(this, File, file_index) + use cam_pio_utils, only: cam_pio_get_decomp, cam_pio_newdecomp + use pio, only: file_desc_t, pio_double + use pio, only: pio_put_var, pio_write_darray + use pio, only: pio_bcast_error, pio_seterrorhandling + !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! + !!XXgoldyXX: The issue is cam_pio_utils depending on stuff in this module + use pio, only: io_desc_t, pio_freedecomp, pio_syncfile + !!XXgoldyXX: End of this part of the hack + + ! Dummy arguments + class(horiz_coord_t), intent(inout) :: this + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + character(len=120) :: errormsg + integer :: ierr + integer :: ldims(1) + integer :: fdims(1) + integer :: err_handling + type(io_desc_t), pointer :: iodesc + integer :: file_index_loc + + nullify(iodesc) + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Check to make sure we are supposed to write this var + if (associated(this%vardesc(file_index_loc)%p)) then + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, & + oldmethod=err_handling) + + ! Write out the values for this dimension variable + if (associated(this%map)) then + ! This is a distributed variable, use pio_write_darray +#if 0 + ldims(1) = this%num_elem() + call this%get_coord_len(fdims(1)) + allocate(iodesc) + call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, this%vardesc(file_index_loc)%p, & + iodesc, this%values, ierr) + nullify(iodesc) ! CAM PIO system takes over memory management of iodesc +#else + !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! + call cam_pio_newdecomp(iodesc, (/this%dimsize/), this%map, pio_double) + call pio_write_darray(File, this%vardesc(file_index_loc)%p, & + iodesc, this%values, ierr) + + call pio_syncfile(File) + call pio_freedecomp(File, iodesc) + ! Take care of bounds if they exist + if (associated(this%bnds) .and. & + associated(this%bndsvdesc(file_index_loc)%p)) then + call cam_pio_newdecomp(iodesc, (/2, this%dimsize/), & + this%map, pio_double) + call pio_write_darray(File, this%bndsvdesc(file_index_loc)%p, & + iodesc, this%bnds, ierr) + call pio_syncfile(File) + call pio_freedecomp(File, iodesc) + end if +#endif + !!XXgoldyXX: End of this part of the hack + else + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, this%vardesc(file_index_loc)%p, & + this%values) + ! Take care of bounds if they exist + if (associated(this%bnds) .and. & + associated(this%bndsvdesc(file_index_loc)%p)) then + ierr = pio_put_var(File, this%bndsvdesc(file_index_loc)%p, & + this%bnds) + end if + end if + write(errormsg, *) 'Error writing variable values for ', & + trim(this%name), ' in write_horiz_coord_var' + call cam_pio_handle_error(ierr, errormsg) + + ! Back to old error handling + call pio_seterrorhandling(File, err_handling) + + ! We are done with this variable descriptor, reset for next file + deallocate(this%vardesc(file_index_loc)%p) + nullify(this%vardesc(file_index_loc)%p) + ! Same with the bounds descriptor + if (associated(this%bndsvdesc(file_index_loc)%p)) then + deallocate(this%bndsvdesc(file_index_loc)%p) + nullify(this%bndsvdesc(file_index_loc)%p) + end if + end if ! Do we write the variable? + + end subroutine write_horiz_coord_var + + !!####################################################################### + !! + !! CAM grid functions + !! + !!####################################################################### + + integer function get_cam_grid_index_char(gridname) + ! Dummy arguments + character(len=*), intent(in) :: gridname + ! Local variables + integer :: i + + get_cam_grid_index_char = -1 + do i = 1, registeredhgrids + if(trim(gridname) == trim(cam_grids(i)%name)) then + get_cam_grid_index_char = i + exit + end if + end do + + end function get_cam_grid_index_char + + integer function get_cam_grid_index_int(gridid) + ! Dummy arguments + integer, intent(in) :: gridid + ! Local variables + integer :: i + + get_cam_grid_index_int = -1 + do i = 1, registeredhgrids + if(gridid == cam_grids(i)%id) then + get_cam_grid_index_int = i + exit + end if + end do + + end function get_cam_grid_index_int + + subroutine find_cam_grid_attr(gridind, name, attr) + ! Dummy arguments + integer, intent(in) :: gridind + character(len=*), intent(in) :: name + class(cam_grid_attribute_t), pointer, intent(out) :: attr + ! Local variable + type(cam_grid_attr_ptr_t), pointer :: attrPtr + + nullify(attr) + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) + !!XXgoldyXX: Is this not working in PGI? + ! attr => attrPtr%getAttr() + attr => attrPtr%attr + if (trim(name) == trim(attr%name)) then + exit + else + !!XXgoldyXX: Is this not working in PGI? + ! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + nullify(attr) + end if + end do + return ! attr should be NULL if not found + end subroutine find_cam_grid_attr + + logical function cam_grid_attr_exists(gridname, name) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + ! Local variables + class(cam_grid_attribute_t), pointer :: attr + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, name, attr) + cam_grid_attr_exists = associated(attr) + nullify(attr) + else + call endrun('cam_grid_attr_exists: Bad grid name, "'//trim(gridname)//'"') + end if + end function cam_grid_attr_exists + + integer function num_cam_grid_attrs(gridind) + ! Dummy arguments + integer, intent(in) :: gridind + + ! Local variables + class(cam_grid_attr_ptr_t), pointer :: attrPtr + + num_cam_grid_attrs = 0 + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) + num_cam_grid_attrs = num_cam_grid_attrs + 1 + !!XXgoldyXX: Is this not working in PGI? + ! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + end function num_cam_grid_attrs + + subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & + unstruct, block_indexed, zonal_grid, src_in, dest_in) + ! Dummy arguments + character(len=*), intent(in) :: name + integer, intent(in) :: id + type(horiz_coord_t), pointer, intent(in) :: lat_coord + type(horiz_coord_t), pointer, intent(in) :: lon_coord + integer(iMap), pointer, intent(in) :: map(:,:) + logical, optional, intent(in) :: unstruct + logical, optional, intent(in) :: block_indexed + logical, optional, intent(in) :: zonal_grid + integer, optional, intent(in) :: src_in(2) + integer, optional, intent(in) :: dest_in(2) + + ! Local variables + character(len=max_hcoordname_len) :: latdimname, londimname + character(len=120) :: errormsg + integer :: i + integer :: src(2), dest(2) + character(len=*), parameter :: subname = 'CAM_GRID_REGISTER' + + ! For a values grid, we do not allow multiple calls + if (get_cam_grid_index(trim(name)) > 0) then + call endrun(trim(subname)//': Grid, '//trim(name)//', already exists') + else if (get_cam_grid_index(id) > 0) then + i = get_cam_grid_index(id) + write(errormsg, '(4a,i5,3a)') trim(subname), & + ': Attempt to add grid, ', trim(name), ' with id = ', id, & + ', however, grid ', trim(cam_grids(i)%name), & + ' already has that ID' + call endrun(trim(errormsg)) + else if (registeredhgrids >= maxhgrids) then + call endrun(trim(subname)//": Too many grids") + else + registeredhgrids = registeredhgrids + 1 + cam_grids(registeredhgrids)%name = trim(name) + cam_grids(registeredhgrids)%id = id + ! Quick sanity checks to make sure these aren't mixed up + if (.not. lat_coord%latitude) then + call endrun(subname//': lat_coord is not a latitude coordinate') + end if + if (lon_coord%latitude) then + call endrun(subname//': lon_coord is not a longitude coordinate') + end if + cam_grids(registeredhgrids)%lat_coord => lat_coord + cam_grids(registeredhgrids)%lon_coord => lon_coord + call lat_coord%get_dim_name(latdimname) + call lon_coord%get_dim_name(londimname) + if (present(unstruct)) then + cam_grids(registeredhgrids)%unstructured = unstruct + else + if (trim(latdimname) == trim(londimname)) then + cam_grids(registeredhgrids)%unstructured = .true. + else + cam_grids(registeredhgrids)%unstructured = .false. + end if + end if + if (present(block_indexed)) then + cam_grids(registeredhgrids)%block_indexed = block_indexed + else + cam_grids(registeredhgrids)%block_indexed = cam_grids(registeredhgrids)%unstructured + end if + if (present(zonal_grid)) then + ! Check the size of the longitude coordinate + call lon_coord%get_coord_len(i) + if (i /= 1) then + call endrun(subname//': lon_coord is not of size 1 for a zonal grid') + end if + cam_grids(registeredhgrids)%zonal_grid = zonal_grid + else + cam_grids(registeredhgrids)%zonal_grid = .false. + end if + if (associated(cam_grids(registeredhgrids)%map)) then + call endrun(trim(subname)//": new grid map should not be associated") + end if + if (present(src_in)) then + src = src_in + else + src(1) = 1 + src(2) = -1 + end if + if (present(dest_in)) then + dest = dest_in + else + dest(1) = 1 + if (cam_grids(registeredhgrids)%unstructured) then + dest(2) = 0 + else + dest(2) = 2 + end if + end if + allocate(cam_grids(registeredhgrids)%map) + call cam_grids(registeredhgrids)%map%init(map, & + cam_grids(registeredhgrids)%unstructured, src, dest) + call cam_grids(registeredhgrids)%print_cam_grid() + end if + + end subroutine cam_grid_register + + subroutine print_cam_grid(this) + class(cam_grid_t) :: this + + type(cam_grid_attr_ptr_t), pointer :: attrPtr + class(cam_grid_attribute_t), pointer :: attr + if (masterproc) then + write(iulog, '(3a,i4,4a,3(a,l2))') 'Grid: ', trim(this%name), & + ', ID = ', this%id, & + ', lat coord = ', trim(this%lat_coord%name), & + ', lon coord = ', trim(this%lon_coord%name), & + ', unstruct = ', this%unstructured, & + ', block_ind = ', this%block_indexed, & + ', zonal_grid = ', this%zonal_grid + attrPtr => this%attributes + do while (associated(attrPtr)) + !!XXgoldyXX: Is this not working in PGI? + ! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%print_attr() + !!XXgoldyXX: Is this not working in PGI? + ! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + end if + end subroutine print_cam_grid + + integer function cam_grid_num_grids() + cam_grid_num_grids = registeredhgrids + end function cam_grid_num_grids + + ! Return .true. iff id represents a valid CAM grid + logical function cam_grid_check(id) + ! Dummy argument + integer, intent(in) :: id + + cam_grid_check = ((get_cam_grid_index(id) > 0) .and. & + (get_cam_grid_index(id) <= cam_grid_num_grids())) + end function cam_grid_check + + integer function cam_grid_id(name) + ! Dummy argument + character(len=*), intent(in) :: name + + ! Local variable + integer :: index + + index = get_cam_grid_index(name) + if (index > 0) then + cam_grid_id = cam_grids(index)%id + else + cam_grid_id = -1 + end if + + end function cam_grid_id + + ! Return the size of a local array for grid, ID. + ! With no optional argument, return the basic 2D array size + ! nlev represents levels or the total column size (product(mdims)) + integer function cam_grid_get_local_size(id, nlev) + + ! Dummy arguments + integer, intent(in) :: id + integer, optional, intent(in) :: nlev + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + cam_grid_get_local_size = cam_grids(gridid)%num_elem() + if (present(nlev)) then + cam_grid_get_local_size = cam_grid_get_local_size * nlev + end if + else + write(errormsg, *) 'cam_grid_get_local_size: Bad grid ID, ', id + call endrun(errormsg) + end if + + end function cam_grid_get_local_size + + ! Given some array information, find the dimension NetCDF IDs on + ! for this grid + subroutine cam_grid_get_file_dimids(id, File, dimids) + use pio, only: file_desc_t + + ! Dummy arguments + integer, intent(in) :: id + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(out) :: dimids(:) + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%find_dimids(File, dimids) + else + write(errormsg, *) 'cam_grid_get_file_dimids: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_get_file_dimids + + ! Given some array information, find or compute a PIO decomposition + subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, & + iodesc, field_dnames, file_dnames) + use pio, only: io_desc_t + + ! Dummy arguments + integer, intent(in) :: id + ! field_lens: Array dim sizes + integer, intent(in) :: field_lens(:) + ! file_lens: File dim sizes + integer, intent(in) :: file_lens(:) + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + character(len=*), optional, intent(in) :: field_dnames(:) + character(len=*), optional, intent(in) :: file_dnames(:) + + ! Local variables + integer :: gridid + character(len=128) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%get_decomp(field_lens, file_lens, dtype, & + iodesc, field_dnames, file_dnames) + else + write(errormsg, *) 'cam_grid_get_decomp: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_get_decomp + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_2d_int + ! + ! Interface function for the grid%read_darray_2d_int method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_int(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_2d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_3d_int + ! + ! Interface function for the grid%read_darray_2d_ method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_int(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_3d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_2d_double + ! + ! Interface function for the grid%read_darray_2d_double method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_double(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_2d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_3d_double + ! + ! Interface function for the grid%read_darray_3d_double method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_double(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_3d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_2d_real + ! + ! Interface function for the grid%read_darray_2d_real method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_2d_real(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_2d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_2d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_dist_array_3d_real + ! + ! Interface function for the grid%read_darray_3d_real method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%read_darray_3d_real(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_read_dist_array_3d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_read_dist_array_3d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_2d_int + ! + ! Interface function for the grid%write_darray_2d_int method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_int(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_2d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_3d_int + ! + ! Interface function for the grid%write_darray_3d_int method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_int(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_3d_int: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_1d_double + ! + ! Interface function for the grid%write_darray_1d_double method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_1d_double(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_1d_double(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_1d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_1d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_2d_double + ! + ! Interface function for the grid%write_darray_2d_double method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_double(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_2d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_3d_double + ! + ! Interface function for the grid%write_darray_3d_double method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_double(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_3d_double: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_1d_real + ! + ! Interface function for the grid%write_darray_1d_real method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_1d_real(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_1d_real(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_1d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_1d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_2d_real + ! + ! Interface function for the grid%write_darray_2d_real method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, & + hbuf, varid) use pio, only: file_desc_t - import :: cam_grid_attribute_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_2d_real(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_2d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_2d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_dist_array_3d_real + ! + ! Interface function for the grid%write_darray_3d_real method + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: id + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variable + integer :: gridid + character(len=120) :: errormsg + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%write_darray_3d_real(File, adims, fdims, & + hbuf, varid) + else + write(errormsg, *) & + 'cam_grid_write_dist_array_3d_real: Bad grid ID, ', id + call endrun(errormsg) + end if + + end subroutine cam_grid_write_dist_array_3d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_gcid + ! + ! Find the global column ID for every local column + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_gcid(id, gcid) + + ! Dummy arguments + integer, intent(in) :: id + integer(iMap), pointer :: gcid(:) + + ! Local variables + integer :: gridid + integer :: fieldbounds(2,2) + integer :: fieldlens(2) + integer :: filelens(2) + type(cam_filemap_t), pointer :: map + + gridid = get_cam_grid_index(id) + if ((gridid > 0) .and. (gridid <= cam_grid_num_grids())) then + map => cam_grids(gridid)%map + call cam_grids(gridid)%coord_lengths(filelens) + call map%array_bounds(fieldbounds) + fieldlens(:) = fieldbounds(:,2) - fieldbounds(:,1) + 1 + call map%get_filemap(fieldlens, filelens, gcid) + else + call endrun('cam_grid_get_gcid: Bad grid ID') + end if + end subroutine cam_grid_get_gcid + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_array_bounds: Return grid bounds for the relevant array + ! Only modifies the dimensions corresponding to the map's src + ! dims should be sized (rank,2) with the second dimension used + ! to store lower(1) and upper(2) bounds + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_array_bounds(id, dims) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(inout) :: dims(:,:) + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_get_array_bounds: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + call cam_grids(gridid)%map%array_bounds(dims) + end if + else + call endrun('cam_grid_get_array_bounds: Bad grid ID') + end if + + end subroutine cam_grid_get_array_bounds + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_coord_names: Return the names of the grid axes + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_coord_names(id, lon_name, lat_name) + + ! Dummy arguments + integer, intent(in) :: id + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: lat_name + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%coord_names(lon_name, lat_name) + else + call endrun('cam_grid_get_coord_names: Bad grid ID') + end if + + end subroutine cam_grid_get_coord_names + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_dim_names: Return the names of the grid axes dimensions. + ! Note that these may be the same + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_dim_names_id(id, name1, name2) + + ! Dummy arguments + integer, intent(in) :: id + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%dim_names(name1, name2) + else + call endrun('cam_grid_get_dim_names_id: Bad grid ID') + end if + + end subroutine cam_grid_get_dim_names_id + + subroutine cam_grid_get_dim_names_name(gridname, name1, name2) + + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + ! Local variables + integer :: gridind + character(len=120) :: errormsg + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind < 0) then + write(errormsg, *) 'No CAM grid with name = ', trim(gridname) + call endrun('cam_grid_get_dim_names_name: '//errormsg) + else + call cam_grids(gridind)%dim_names(name1, name2) + end if + + end subroutine cam_grid_get_dim_names_name + + logical function cam_grid_has_blocksize(id) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_has_blocksize: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + cam_grid_has_blocksize = cam_grids(gridid)%map%has_blocksize() + end if + else + call endrun('cam_grid_has_blocksize: Bad grid ID') + end if + end function cam_grid_has_blocksize + + ! Return the number of active columns in the block specified by block_id + integer function cam_grid_get_block_count(id, block_id) result(ncol) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(in) :: block_id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%map)) then + call endrun('cam_grid_get_block_count: Grid, '//trim(cam_grids(gridid)%name)//', has no map') + else + ncol = cam_grids(gridid)%map%blocksize(block_id) + end if + else + call endrun('cam_grid_get_block_count: Bad grid ID') + end if + end function cam_grid_get_block_count + + function cam_grid_get_latvals(id) result(latvals) + + ! Dummy argument + integer, intent(in) :: id + real(r8), pointer :: latvals(:) + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%lat_coord%values)) then + nullify(latvals) + else + latvals => cam_grids(gridid)%lat_coord%values + end if + else + call endrun('cam_grid_get_latvals: Bad grid ID') + end if + end function cam_grid_get_latvals + + function cam_grid_get_lonvals(id) result(lonvals) + ! Dummy arguments - class(cam_grid_attribute_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - end subroutine write_cam_grid_attr - end interface - - ! Abstract interface for print_attr procedure of cam_grid_attribute_t class - abstract interface - subroutine print_attr_spec(this) - import :: cam_grid_attribute_t + integer, intent(in) :: id + real(r8), pointer :: lonvals(:) + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + if (.not. associated(cam_grids(gridid)%lon_coord%values)) then + nullify(lonvals) + else + lonvals => cam_grids(gridid)%lon_coord%values + end if + else + call endrun('cam_grid_get_lonvals: Bad grid ID') + end if + end function cam_grid_get_lonvals + + ! Find the longitude and latitude of a range of map entries + ! beg and end are the range of the first source index. blk is a block or chunk index + subroutine cam_grid_get_coords(id, beg, end, blk, lon, lat) + + ! Dummy arguments + integer, intent(in) :: id + integer, intent(in) :: beg + integer, intent(in) :: end + integer, intent(in) :: blk + real(r8), intent(inout) :: lon(:) + real(r8), intent(inout) :: lat(:) + + ! Local variables + integer :: gridid + integer :: i + gridid = get_cam_grid_index(id) + if (gridid > 0) then + do i = beg, end + if (cam_grids(gridid)%is_unstructured()) then + call endrun('cam_grid_get_coords: Not implemented') + else + call endrun('cam_grid_get_coords: Not implemented') + end if + end do + else + call endrun('cam_grid_get_coords: Bad grid ID') + end if + end subroutine cam_grid_get_coords + + logical function cam_grid_is_unstructured(id) result(unstruct) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + unstruct = cam_grids(gridid)%is_unstructured() + else + call endrun('cam_grid_is_unstructured: Bad grid ID') + end if + end function cam_grid_is_unstructured + + logical function cam_grid_is_block_indexed(id) result(block_indexed) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + block_indexed = cam_grids(gridid)%is_block_indexed() + else + call endrun('s: Bad grid ID') + end if + end function cam_grid_is_block_indexed + + logical function cam_grid_is_zonal(id) result(zonal) + + ! Dummy arguments + integer, intent(in) :: id + + ! Local variables + integer :: gridid + gridid = get_cam_grid_index(id) + if (gridid > 0) then + zonal = cam_grids(gridid)%is_zonal_grid() + else + call endrun('s: Bad grid ID') + end if + end function cam_grid_is_zonal + + ! Compute or update a grid patch mask + subroutine cam_grid_compute_patch(id, patch, lonl, lonu, latl, latu, cco) + + ! Dummy arguments + integer, intent(in) :: id + type(cam_grid_patch_t), intent(inout) :: patch + real(r8), intent(in) :: lonl + real(r8), intent(in) :: lonu + real(r8), intent(in) :: latl + real(r8), intent(in) :: latu + logical, intent(in) :: cco ! Collect cols? + + ! Local variables + integer :: gridid + + gridid = get_cam_grid_index(id) + if (gridid > 0) then + call cam_grids(gridid)%get_patch_mask(lonl, lonu, latl, latu, patch, cco) + else + call endrun('cam_grid_compute_patch: Bad grid ID') + end if + + end subroutine cam_grid_compute_patch + + !!####################################################################### + !! + !! CAM grid attribute functions + !! + !!####################################################################### + + subroutine cam_grid_attr_init(this, name, long_name, next) + ! Dummy arguments + class(cam_grid_attribute_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + class(cam_grid_attribute_t), pointer :: next + + this%name = trim(name) + this%long_name = trim(long_name) + this%next => next + end subroutine cam_grid_attr_init + + subroutine print_attr_base(this) + ! Dummy arguments + class(cam_grid_attribute_t), intent(in) :: this + if (masterproc) then + write(iulog, '(5a)') 'Attribute: ', trim(this%name), & + ", long name = '", trim(this%long_name), "'" + end if + end subroutine print_attr_base + + subroutine cam_grid_attr_init_0d_int(this, name, long_name, val) + ! Dummy arguments + class(cam_grid_attribute_0d_int_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + integer, intent(in) :: val + + ! call this%cam_grid_attr_init(name, '') + this%name = trim(name) + this%long_name = trim(long_name) + this%ival = val + end subroutine cam_grid_attr_init_0d_int + + subroutine print_attr_0d_int(this) + ! Dummy arguments + class(cam_grid_attribute_0d_int_t), intent(in) :: this + + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' value = ', this%ival + end if + end subroutine print_attr_0d_int + + subroutine cam_grid_attr_init_0d_char(this, name, long_name, val) + ! Dummy arguments + class(cam_grid_attribute_0d_char_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: val + + ! call this%cam_grid_attr_init(name, '') + this%name = trim(name) + this%long_name = trim(long_name) + this%val = trim(val) + end subroutine cam_grid_attr_init_0d_char + + subroutine print_attr_0d_char(this) + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(in) :: this + + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' value = ', trim(this%val) + end if + end subroutine print_attr_0d_char + + subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & + dimsize, values, map) + ! Dummy arguments + class(cam_grid_attribute_1d_int_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + integer, target, intent(in) :: values(:) + integer(iMap), optional, target, intent(in) :: map(:) + + ! call this%cam_grid_attr_init(trim(name), trim(long_name)) + if (len_trim(name) > max_hcoordname_len) then + call endrun('cam_grid_attr_1d_int: name too long') + end if + this%name = trim(name) + if (len_trim(long_name) > max_chars) then + call endrun('cam_grid_attr_1d_int: long_name too long') + end if + this%long_name = trim(long_name) + + if (len_trim(dimname) > max_hcoordname_len) then + call endrun('cam_grid_attr_1d_int: dimname too long') + end if + this%dimname = trim(dimname) + this%dimsize = dimsize + this%values => values + ! Fill in the optional map + if (present(map)) then + allocate(this%map(size(map))) + this%map(:) = map(:) + else + nullify(this%map) + end if + end subroutine cam_grid_attr_init_1d_int + + subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & + dimsize, values, map) + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t) :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimsize + real(r8), target, intent(in) :: values(:) + integer(iMap), optional, target, intent(in) :: map(:) + + ! call this%cam_grid_attr_init(trim(name), trim(long_name), next) + this%name = trim(name) + this%long_name = trim(long_name) + + this%dimname = trim(dimname) + this%dimsize = dimsize + this%values => values + ! Fill in the optional map + if (present(map)) then + allocate(this%map(size(map))) + this%map(:) = map(:) + else + nullify(this%map) + end if + end subroutine cam_grid_attr_init_1d_r8 + + subroutine print_attr_1d_int(this) + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(in) :: this + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' dimname = ', trim(this%dimname) + end if + end subroutine print_attr_1d_int + + subroutine print_attr_1d_r8(this) + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(in) :: this + call this%print_attr_base() + if (masterproc) then + write(iulog, *) ' dimname = ', trim(this%dimname) + end if + end subroutine print_attr_1d_r8 + + subroutine insert_grid_attribute(gridind, attr) + integer, intent(in) :: gridind + class(cam_grid_attribute_t), pointer :: attr + + ! Push a new attribute onto the grid + type(cam_grid_attr_ptr_t), pointer :: attrPtr + + allocate(attrPtr) + call attrPtr%initialize(attr) + call attrPtr%setNext(cam_grids(gridind)%attributes) + cam_grids(gridind)%attributes => attrPtr + call attrPtr%attr%print_attr() + end subroutine insert_grid_attribute + + subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + integer, intent(in) :: val + + ! Local variables + type(cam_grid_attribute_0d_int_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_0d_int: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) + else + ! Need a new attribute. + allocate(attr) + call attr%cam_grid_attr_init_0d_int(trim(name), & + trim(long_name), val) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_int: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if + ! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_0d_int + + subroutine add_cam_grid_attribute_0d_char(gridname, name, val) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: val + + ! Local variables + type(cam_grid_attribute_0d_char_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_0d_char: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) + else + ! Need a new attribute. + allocate(attr) + call attr%cam_grid_attr_init_0d_char(trim(name), '', val) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_char: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if + ! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_0d_char + + subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & + dimname, values, map) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + integer, intent(in), target :: values(:) + integer(iMap), intent(in), target, optional :: map(:) + + ! Local variables + type(cam_grid_attribute_1d_int_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + integer :: dimsize + + nullify(attr) + nullify(attptr) + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_1d_int: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) + else + ! Need a new attribute. + dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) + if (dimsize < 1) then + dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) + end if + if (dimsize < 1) then + write(errormsg, *) & + 'add_cam_grid_attribute_1d_int: attribute ', & + 'dimension ', trim(dimname), ' for ', trim(name), & + ', not found' + call endrun(errormsg) + end if + allocate(attr) + call attr%cam_grid_attr_init_1d_int(trim(name), & + trim(long_name), trim(dimname), dimsize, values, map) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_int: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if + ! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_1d_int + + subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & + dimname, values, map) + ! Dummy arguments + character(len=*), intent(in) :: gridname + character(len=*), intent(in) :: name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: dimname + real(r8), intent(in), target :: values(:) + integer(iMap), intent(in), target, optional :: map(:) + + ! Local variables + type(cam_grid_attribute_1d_r8_t), pointer :: attr + class(cam_grid_attribute_t), pointer :: attptr + character(len=120) :: errormsg + integer :: gridind + integer :: dimsize + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind > 0) then + call find_cam_grid_attr(gridind, trim(name), attptr) + if (associated(attptr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') & + 'add_cam_grid_attribute_1d_r8: attribute ', trim(name), & + ' already exists for ', cam_grids(gridind)%name + call endrun(errormsg) + else + ! Need a new attribute. + dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) + if (dimsize < 1) then + dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) + end if + if (dimsize < 1) then + write(errormsg, *) & + 'add_cam_grid_attribute_1d_r8: attribute ', & + 'dimension ', trim(dimname), ' for ', trim(name), & + ', not found' + call endrun(errormsg) + end if + allocate(attr) + call attr%cam_grid_attr_init_1d_r8(trim(name), & + trim(long_name), trim(dimname), dimsize, values, map) + attptr => attr + call insert_grid_attribute(gridind, attptr) + end if + else + write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_r8: grid ', & + trim(gridname), ' was not found' + call endrun(errormsg) + end if + ! call cam_grids(gridind)%print_cam_grid() + end subroutine add_cam_grid_attribute_1d_r8 + + !!####################################################################### + !! + !! CAM grid attribute pointer (list node) functions + !! + !!####################################################################### + + subroutine initializeAttrPtr(this, attr) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + class(cam_grid_attribute_t), target :: attr + + if (associated(this%next)) then + if (masterproc) then + write(iulog, *) 'WARNING: Overwriting attr pointer for ', & + 'cam_grid_attr_ptr_t' + end if + end if + this%attr => attr + end subroutine initializeAttrPtr + + function getAttrPtrAttr(this) + ! Dummy variable + class(cam_grid_attr_ptr_t) :: this + class(cam_grid_attribute_t), pointer :: getAttrPtrAttr + + getAttrPtrAttr => this%attr + end function getAttrPtrAttr + + function getAttrPtrNext(this) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + type(cam_grid_attr_ptr_t), pointer :: getAttrPtrNext + + getAttrPtrNext => this%next + end function getAttrPtrNext + + subroutine setAttrPtrNext(this, next) + ! Dummy arguments + class(cam_grid_attr_ptr_t) :: this + type(cam_grid_attr_ptr_t), pointer :: next + + if (associated(this%next)) then + if (masterproc) then + write(iulog, *) 'WARNING: Overwriting next pointer for cam_grid_attr_ptr_t' + end if + end if + this%next => next + end subroutine setAttrPtrNext + + !------------------------------------------------------------------------ + ! + ! write_cam_grid_attr_0d_int + ! + ! Write a grid attribute + ! + !------------------------------------------------------------------------ + + subroutine write_cam_grid_attr_0d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, & + pio_inq_att, PIO_GLOBAL + use cam_pio_utils, only: cam_pio_def_var + + ! Dummy arguments + class(cam_grid_attribute_0d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: attrtype + integer(imap) :: attrlen + integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_attr_0d_int' + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + if (len_trim(attr%long_name) > 0) then + ! This 0d attribute is a scalar variable with a + ! long_name attribute + ! First, define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_int, & + attr%vardesc(file_index_loc)%p, existOK=.false.) + ierr= pio_put_att(File, attr%vardesc(file_index_loc)%p, & + '_FillValue', int(grid_fill_value)) + call cam_pio_handle_error(ierr, & + 'Error writing "_FillValue" attr in '//subname) + ierr=pio_put_att(File, attr%vardesc(file_index_loc)%p, & + 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, & + 'Error writing "long_name" attr in '//subname) + else + ! This 0d attribute is a global attribute + ! Check to see if the attribute already exists in the file + ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, & + attrlen) + if (ierr /= PIO_NOERR) then + ! Time to define the attribute + ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), & + attr%ival) + call cam_pio_handle_error(ierr, & + 'Unable to define attribute in '//subname) + end if + end if + end if + + end subroutine write_cam_grid_attr_0d_int + + !------------------------------------------------------------------------ + ! + ! write_cam_grid_attr_0d_char + ! + ! Write a grid attribute + ! + !------------------------------------------------------------------------ + + subroutine write_cam_grid_attr_0d_char(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr, & + pio_inq_att, PIO_GLOBAL + + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: attrtype + integer(imap) :: attrlen + integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_attr_0d_char' + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! The 0d char attributes are global attribues + ! Check to see if the attribute already exists in the file + ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) + if (ierr /= PIO_NOERR) then + ! Time to define the variable + ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%val) + call cam_pio_handle_error(ierr, & + 'Unable to define attribute in '//subname) + end if + end if + + end subroutine write_cam_grid_attr_0d_char + + !------------------------------------------------------------------------ + ! + ! write_cam_grid_attr_1d_int + ! + ! Write a grid attribute + ! + !------------------------------------------------------------------------ + + subroutine write_cam_grid_attr_1d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr + use pio, only: pio_inq_dimid, pio_int + use cam_pio_utils, only: cam_pio_def_var + + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: dimid ! PIO dimension ID + character(len=120) :: errormsg + integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_int' + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! Check to see if the dimension already exists in the file + ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) + if (ierr /= PIO_NOERR) then + ! The dimension has not yet been defined. This is an error + ! NB: It should have been defined as part of a coordinate + write(errormsg, *) 'write_cam_grid_attr_1d_int: dimension, ', & + trim(attr%dimname), ', does not exist' + call endrun(errormsg) + end if + ! Time to define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), & + attr%vardesc(file_index_loc)%p, existOK=.false.) + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, & + '_FillValue', int(grid_fill_value)) + call cam_pio_handle_error(ierr, & + 'Error writing "_FillValue" attr in '//subname) + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, & + 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, & + 'Error writing "long_name" attr in '//subname) + end if + + end subroutine write_cam_grid_attr_1d_int + + !------------------------------------------------------------------------ + ! + ! write_cam_grid_attr_1d_r8 + ! + ! Write a grid attribute + ! + !------------------------------------------------------------------------ + + subroutine write_cam_grid_attr_1d_r8(attr, File, file_index) + use pio, only: file_desc_t, pio_put_att, pio_noerr + use pio, only: pio_double, pio_inq_dimid + use cam_pio_utils, only: cam_pio_def_var + + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File ! PIO file + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: dimid ! PIO dimension ID + character(len=120) :: errormsg + integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_r8' + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is associated, that grid defined the attribute + if (.not. associated(attr%vardesc(file_index_loc)%p)) then + ! Check to see if the dimension already exists in the file + ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) + if (ierr /= PIO_NOERR) then + ! The dimension has not yet been defined. This is an error + ! NB: It should have been defined as part of a coordinate + write(errormsg, *) 'write_cam_grid_attr_1d_r8: dimension, ', & + trim(attr%dimname), ', does not exist' + call endrun(errormsg) + end if + ! Time to define the variable + allocate(attr%vardesc(file_index_loc)%p) + call cam_pio_def_var(File, trim(attr%name), pio_double, & + (/dimid/), attr%vardesc(file_index_loc)%p, existOK=.false.) + ! fill value + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, & + '_FillValue', grid_fill_value) + call cam_pio_handle_error(ierr, & + 'Error writing "_FillValue" attr in '//subname) + ! long_name + ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, & + 'long_name', trim(attr%long_name)) + call cam_pio_handle_error(ierr, & + 'Error writing "long_name" attr in '//subname) + end if + + end subroutine write_cam_grid_attr_1d_r8 + + !------------------------------------------------------------------------ + ! + ! cam_grid_attribute_copy + ! + ! Copy an attribute from a source grid to a destination grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name) + ! Dummy arguments + character(len=*), intent(in) :: src_grid + character(len=*), intent(in) :: dest_grid + character(len=*), intent(in) :: attribute_name + + ! Local variables + character(len=120) :: errormsg + integer :: src_ind, dest_ind + class(cam_grid_attribute_t), pointer :: attr + + ! Find the source and destination grid indices + src_ind = get_cam_grid_index(trim(src_grid)) + dest_ind = get_cam_grid_index(trim(dest_grid)) + + call find_cam_grid_attr(dest_ind, trim(attribute_name), attr) + if (associated(attr)) then + ! Attribute found, can't add it again! + write(errormsg, '(4a)') 'CAM_GRID_ATTRIBUTE_COPY: attribute ', & + trim(attribute_name), ' already exists for ', & + cam_grids(dest_ind)%name + call endrun(errormsg) + else + call find_cam_grid_attr(src_ind, trim(attribute_name), attr) + if (associated(attr)) then + ! Copy the attribute + call insert_grid_attribute(dest_ind, attr) + else + write(errormsg, '(4a)') ": Did not find attribute, '", & + trim(attribute_name), "' in ", cam_grids(src_ind)%name + call endrun("CAM_GRID_ATTRIBUTE_COPY"//errormsg) + end if + end if + + end subroutine cam_grid_attribute_copy + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_attr + ! + ! Write the dimension and coordinate attributes for the horizontal + ! history coordinates. + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_attr(File, grid_id, header_info, file_index) + use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use pio, only: pio_inq_dimid + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: grid_id + type(cam_grid_header_info_t), intent(inout) :: header_info + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: gridind + class(cam_grid_attribute_t), pointer :: attr + type(cam_grid_attr_ptr_t), pointer :: attrPtr + integer :: dimids(2) + integer :: err_handling + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if + + gridind = get_cam_grid_index(grid_id) + !! Fill this in to make sure history finds grid + header_info%grid_id = grid_id + + if (allocated(header_info%hdims)) then + deallocate(header_info%hdims) + end if + + if (associated(header_info%lon_varid)) then + ! This could be a sign of bad memory management + call endrun('CAM_GRID_WRITE_ATTR: lon_varid should be NULL') + end if + if (associated(header_info%lat_varid)) then + ! This could be a sign of bad memory management + call endrun('CAM_GRID_WRITE_ATTR: lat_varid should be NULL') + end if + + ! Only write this grid if not already defined + if (cam_grids(gridind)%attrs_defined(file_index_loc)) then + ! We need to fill out the hdims info for this grid + call cam_grids(gridind)%find_dimids(File, dimids) + if (dimids(2) < 0) then + allocate(header_info%hdims(1)) + header_info%hdims(1) = dimids(1) + else + allocate(header_info%hdims(2)) + header_info%hdims(1:2) = dimids(1:2) + end if + else + ! Write the horizontal coord attributes first so that we have + ! the dims + call cam_grids(gridind)%lat_coord%write_attr(File, dimids(2), & + file_index=file_index_loc) + call cam_grids(gridind)%lon_coord%write_attr(File, dimids(1), & + file_index=file_index_loc) + + if (dimids(2) == dimids(1)) then + allocate(header_info%hdims(1)) + else + allocate(header_info%hdims(2)) + header_info%hdims(2) = dimids(2) + end if + header_info%hdims(1) = dimids(1) + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, & + oldmethod=err_handling) + + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) + !!XXgoldyXX: Is this not working in PGI? + ! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%write_attr(File, file_index=file_index_loc) + !!XXgoldyXX: Is this not working in PGI? + ! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + + ! Back to previous I/O error handling + call pio_seterrorhandling(File, err_handling) + cam_grids(gridind)%attrs_defined(file_index_loc) = .true. + end if + + end subroutine cam_grid_write_attr + + subroutine write_cam_grid_val_0d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_inq_varid, pio_put_var + ! Dummy arguments - class(cam_grid_attribute_t), intent(in) :: this - end subroutine print_attr_spec - end interface - - !! Grid variables - integer, parameter :: maxhgrids = 16 ! arbitrary limit - integer, save :: registeredhgrids = 0 - type(cam_grid_t), save :: cam_grids(maxhgrids) - - public :: horiz_coord_create - - ! Setup and I/O functions for grids rely on the grid's ID, not its index. - public :: cam_grid_register, cam_grid_attribute_register - public :: cam_grid_attribute_copy - public :: cam_grid_write_attr, cam_grid_write_var - public :: cam_grid_read_dist_array, cam_grid_write_dist_array - ! Access functions for grids rely on the grid's ID or name, not its index. - public :: cam_grid_dimensions, cam_grid_num_grids - public :: cam_grid_check ! T/F if grid ID exists - public :: cam_grid_id ! Grid ID (decomp) or -1 if error - public :: cam_grid_get_local_size - public :: cam_grid_get_file_dimids - public :: cam_grid_get_decomp - public :: cam_grid_get_gcid - public :: cam_grid_get_array_bounds - public :: cam_grid_get_coord_names, cam_grid_get_dim_names - public :: cam_grid_has_blocksize, cam_grid_get_block_count - public :: cam_grid_get_latvals, cam_grid_get_lonvals - public :: cam_grid_get_coords - public :: cam_grid_is_unstructured, cam_grid_is_block_indexed - public :: cam_grid_attr_exists - public :: cam_grid_is_zonal - ! Functions for dealing with patch masks - public :: cam_grid_compute_patch - ! Functions for dealing with grid areas - public :: cam_grid_get_areawt - - interface cam_grid_attribute_register - module procedure add_cam_grid_attribute_0d_int - module procedure add_cam_grid_attribute_0d_char - module procedure add_cam_grid_attribute_1d_int - module procedure add_cam_grid_attribute_1d_r8 - end interface - - interface cam_grid_dimensions - module procedure cam_grid_dimensions_id - module procedure cam_grid_dimensions_name - end interface - - interface cam_grid_get_dim_names - module procedure cam_grid_get_dim_names_id - module procedure cam_grid_get_dim_names_name - end interface - - interface cam_grid_read_dist_array - module procedure cam_grid_read_dist_array_2d_int - module procedure cam_grid_read_dist_array_3d_int - module procedure cam_grid_read_dist_array_2d_double - module procedure cam_grid_read_dist_array_3d_double - module procedure cam_grid_read_dist_array_2d_real - module procedure cam_grid_read_dist_array_3d_real - end interface - - interface cam_grid_write_dist_array - module procedure cam_grid_write_dist_array_2d_int - module procedure cam_grid_write_dist_array_3d_int - module procedure cam_grid_write_dist_array_1d_double - module procedure cam_grid_write_dist_array_2d_double - module procedure cam_grid_write_dist_array_3d_double - module procedure cam_grid_write_dist_array_1d_real - module procedure cam_grid_write_dist_array_2d_real - module procedure cam_grid_write_dist_array_3d_real - end interface - - ! Private interfaces - interface get_cam_grid_index - module procedure get_cam_grid_index_char ! For lookup by name - module procedure get_cam_grid_index_int ! For lookup by ID - end interface + class(cam_grid_attribute_0d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index -contains + ! Local variables + integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_val_0d_int' -!!####################################################################### -!! -!! Horizontal coordinate functions -!! -!!####################################################################### + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if - integer function horiz_coord_find_size(this, dimname) result(dimsize) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(in) :: dimname - - dimsize = -1 - if (len_trim(this%dimname) == 0) then - if(trim(dimname) == trim(this%name)) then - dimsize = this%dimsize - end if - else - if(trim(dimname) == trim(this%dimname)) then - dimsize = this%dimsize - end if - end if - - end function horiz_coord_find_size - - integer function horiz_coord_num_elem(this) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - - if (associated(this%values)) then - horiz_coord_num_elem = size(this%values) - else - horiz_coord_num_elem = 0 - end if - - end function horiz_coord_num_elem - - subroutine horiz_coord_len(this, clen) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - integer, intent(out) :: clen - - clen = this%dimsize - end subroutine horiz_coord_len - - subroutine horiz_coord_name(this, name) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: name - - if (len(name) < len_trim(this%name)) then - call endrun('horiz_coord_name: input name too short') - end if - name = trim(this%name) - end subroutine horiz_coord_name - - subroutine horiz_coord_dim_name(this, dimname) - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: dimname - - if (len_trim(this%dimname) > 0) then - ! We have a separate dimension name (e.g., ncol) - if (len(dimname) < len_trim(this%dimname)) then - call endrun('horiz_coord_dimname: input name too short') - end if - dimname = trim(this%dimname) - else - ! No dimension name so we use the coordinate's name - ! i.e., The dimension name is the same as the coordinate variable - if (len(dimname) < len_trim(this%name)) then - call endrun('horiz_coord_dimname: input name too short') - end if - dimname = trim(this%name) - end if - end subroutine horiz_coord_dim_name - - subroutine horiz_coord_long_name(this, name) - - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: name - - if (len(name) < len_trim(this%long_name)) then - call endrun('horiz_coord_long_name: input name too short') - else - name = trim(this%long_name) - end if - - end subroutine horiz_coord_long_name - - subroutine horiz_coord_units(this, units) - - ! Dummy arguments - class(horiz_coord_t), intent(in) :: this - character(len=*), intent(out) :: units - - if (len(units) < len_trim(this%units)) then - call endrun('horiz_coord_units: input units too short') - else - units = trim(this%units) - end if - - end subroutine horiz_coord_units - - function horiz_coord_create(name, dimname, dimsize, long_name, units, & - lbound, ubound, values, map, bnds) result(newcoord) - - ! Dummy arguments - character(len=*), intent(in) :: name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: units - ! NB: Sure, pointers would have made sense but . . . PGI - integer, intent(in) :: lbound - integer, intent(in) :: ubound - real(r8), intent(in) :: values(lbound:ubound) - integer(iMap), intent(in), optional :: map(ubound-lbound+1) - real(r8), intent(in), optional :: bnds(2,lbound:ubound) - type(horiz_coord_t), pointer :: newcoord - - allocate(newcoord) - - newcoord%name = trim(name) - newcoord%dimname = trim(dimname) - newcoord%dimsize = dimsize - newcoord%long_name = trim(long_name) - newcoord%units = trim(units) - ! Figure out if this is a latitude or a longitude using CF standard - ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#latitude-coordinate - ! http://cfconventions.org/Data/cf-conventions/cf-conventions-1.6/build/cf-conventions.html#longitude-coordinate - if ( (trim(units) == 'degrees_north') .or. & - (trim(units) == 'degree_north') .or. & - (trim(units) == 'degree_N') .or. & - (trim(units) == 'degrees_N') .or. & - (trim(units) == 'degreeN') .or. & - (trim(units) == 'degreesN')) then - newcoord%latitude = .true. - else if ((trim(units) == 'degrees_east') .or. & - (trim(units) == 'degree_east') .or. & - (trim(units) == 'degree_E') .or. & - (trim(units) == 'degrees_E') .or. & - (trim(units) == 'degreeE') .or. & - (trim(units) == 'degreesE')) then - newcoord%latitude = .false. - else - call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'") - end if - allocate(newcoord%values(lbound:ubound)) - if (ubound >= lbound) then - newcoord%values(:) = values(:) - end if - - if (present(map)) then - if (ANY(map < 0)) then - call endrun("horiz_coord_create "//trim(name)//": map vals < 0") - end if - allocate(newcoord%map(ubound - lbound + 1)) - if (ubound >= lbound) then - newcoord%map(:) = map(:) + ! We only write this var if it is a variable + if (associated(attr%vardesc(file_index_loc)%p)) then + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%ival) + call cam_pio_handle_error(ierr, 'Error writing value in '//subname) + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) end if - else - nullify(newcoord%map) - end if - if (present(bnds)) then - allocate(newcoord%bnds(2, lbound:ubound)) - if (ubound >= lbound) then - newcoord%bnds = bnds - end if - else - nullify(newcoord%bnds) - end if - - end function horiz_coord_create - - !--------------------------------------------------------------------------- - ! - ! write_horiz_coord_attr - ! - ! Write the dimension and coordinate attributes for a horizontal grid - ! coordinate. - ! - !--------------------------------------------------------------------------- - - subroutine write_horiz_coord_attr(this, File, dimid_out, file_index) - use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double - use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid - use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var - - ! Dummy arguments - class(horiz_coord_t), intent(inout) :: this - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(out) :: dimid_out - integer, optional, intent(in) :: file_index - - ! Local variables - type(var_desc_t) :: vardesc - character(len=max_hcoordname_len) :: dimname - integer :: dimid ! PIO dimension ID - integer :: bnds_dimid ! PIO dim ID for bounds - integer :: err_handling - integer :: ierr - integer :: file_index_loc - - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Make sure the dimension exists in the file - call this%get_dim_name(dimname) - call cam_pio_def_dim(File, trim(dimname), this%dimsize, dimid, & - existOK=.true.) - ! Should we define the variable? - ierr = pio_inq_varid(File, trim(this%name), vardesc) - if (ierr /= PIO_NOERR) then - ! Variable not already defined, it is up to us to define the variable - if (associated(this%vardesc(file_index_loc)%p)) then - ! This should not happen (i.e., internal error) - call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname)) - end if - allocate(this%vardesc(file_index_loc)%p) - call cam_pio_def_var(File, trim(this%name), pio_double, & - (/ dimid /), this%vardesc(file_index_loc)%p, existOK=.false.) - ! long_name - ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'long_name', trim(this%long_name)) - call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_horiz_coord_attr') - ! units - ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'units', trim(this%units)) - call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_horiz_coord_attr') - ! Take care of bounds if they exist - if (associated(this%bnds)) then - allocate(this%bndsvdesc(file_index_loc)%p) - ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'bounds', trim(this%name)//'_bnds') - call cam_pio_handle_error(ierr, 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr') - call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.) - call cam_pio_def_var(File, trim(this%name)//'_bnds', pio_double, & - (/ bnds_dimid, dimid /), this%bndsvdesc(file_index_loc)%p, existOK=.false.) - call cam_pio_handle_error(ierr, 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr') - ! long_name - ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'long_name', trim(this%name)//' bounds') - call cam_pio_handle_error(ierr, 'Error writing bounds "long_name" attr in write_horiz_coord_attr') - ! units - ierr=pio_put_att(File, this%bndsvdesc(file_index_loc)%p, 'units', trim(this%units)) - call cam_pio_handle_error(ierr, 'Error writing bounds "units" attr in write_horiz_coord_attr') - end if ! There are bounds for this coordinate - end if ! We define the variable - - if (present(dimid_out)) then - dimid_out = dimid - end if - - ! Back to old error handling - call pio_seterrorhandling(File, err_handling) - - end subroutine write_horiz_coord_attr - - !--------------------------------------------------------------------------- - ! - ! write_horiz_coord_var - ! - ! Write the coordinate values for this coordinate - ! - !--------------------------------------------------------------------------- - - subroutine write_horiz_coord_var(this, File, file_index) - use cam_pio_utils, only: cam_pio_get_decomp - use pio, only: file_desc_t, pio_double, iosystem_desc_t - use pio, only: pio_put_var, pio_write_darray - use pio, only: pio_bcast_error, pio_seterrorhandling - !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! - !!XXgoldyXX: The issue is cam_pio_utils depending on stuff in this module - use pio, only: pio_initdecomp, io_desc_t, pio_freedecomp, pio_syncfile - use cam_instance, only: atm_id - use shr_pio_mod, only: shr_pio_getiosys - !!XXgoldyXX: End of this part of the hack - - ! Dummy arguments - class(horiz_coord_t), intent(inout) :: this - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - - ! Local variables - character(len=120) :: errormsg - integer :: ierr - integer :: ldims(1) - integer :: fdims(1) - integer :: err_handling - type(io_desc_t) :: iodesc - integer :: file_index_loc - !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! - type(iosystem_desc_t), pointer :: piosys - !!XXgoldyXX: End of this part of the hack - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Check to make sure we are supposed to write this var - if (associated(this%vardesc(file_index_loc)%p)) then - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) + end subroutine write_cam_grid_val_0d_int - ! Write out the values for this dimension variable - if (associated(this%map)) then - ! This is a distributed variable, use pio_write_darray -#if 0 - ldims(1) = this%num_elem() - call this%get_coord_len(fdims(1)) - allocate(iodesc) - call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr) - nullify(iodesc) ! CAM PIO system takes over memory management of iodesc -#else - !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! - piosys => shr_pio_getiosys(atm_id) - call pio_initdecomp(piosys, pio_double, (/this%dimsize/), this%map, & - iodesc) - call pio_write_darray(File, this%vardesc(file_index_loc)%p, iodesc, this%values, ierr) - - call pio_syncfile(File) - call pio_freedecomp(File, iodesc) - ! Take care of bounds if they exist - if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then - call pio_initdecomp(piosys, pio_double, (/2, this%dimsize/), & - this%map, iodesc) - call pio_write_darray(File, this%bndsvdesc(file_index_loc)%p, iodesc, this%bnds, ierr) - call pio_syncfile(File) - call pio_freedecomp(File, iodesc) - end if -#endif - !!XXgoldyXX: End of this part of the hack + subroutine write_cam_grid_val_0d_char(attr, File, file_index) + use pio, only: file_desc_t + + ! Dummy arguments + class(cam_grid_attribute_0d_char_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! This subroutine is a stub because global attributes are written + ! in define mode + return + end subroutine write_cam_grid_val_0d_char + + subroutine write_cam_grid_val_1d_int(attr, File, file_index) + use pio, only: file_desc_t, pio_put_var, pio_int, io_desc_t + use pio, only: pio_inq_varid, pio_write_darray + use pio, only: pio_freedecomp + use cam_pio_utils, only: cam_pio_newdecomp + + ! Dummy arguments + class(cam_grid_attribute_1d_int_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: ierr + type(io_desc_t), pointer :: iodesc + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' + + if (present(file_index)) then + file_index_loc = file_index else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, this%vardesc(file_index_loc)%p, this%values) - ! Take care of bounds if they exist - if (associated(this%bnds) .and. associated(this%bndsvdesc(file_index_loc)%p)) then - ierr = pio_put_var(File, this%bndsvdesc(file_index_loc)%p, this%bnds) - end if + file_index_loc = 1 end if - write(errormsg, *) 'Error writing variable values for ',trim(this%name),& - ' in write_horiz_coord_var' - call cam_pio_handle_error(ierr, errormsg) - ! Back to old error handling - call pio_seterrorhandling(File, err_handling) + nullify(iodesc) + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is not associated, another grid write the values + if (associated(attr%vardesc(file_index_loc)%p)) then + ! Write out the values for this dimension variable + if (associated(attr%map)) then + ! This is a distributed variable, use pio_write_darray + allocate(iodesc) + call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & + pio_int) + call pio_write_darray(File, attr%vardesc(file_index_loc)%p, & + iodesc, attr%values, ierr) + call pio_freedecomp(File, iodesc) + deallocate(iodesc) + nullify(iodesc) + else + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, & + attr%values) + end if + call cam_pio_handle_error(ierr, & + 'Error writing variable values in '//subname) + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) + end if - ! We are done with this variable descriptor, reset for next file - deallocate(this%vardesc(file_index_loc)%p) - nullify(this%vardesc(file_index_loc)%p) - ! Same with the bounds descriptor - if (associated(this%bndsvdesc(file_index_loc)%p)) then - deallocate(this%bndsvdesc(file_index_loc)%p) - nullify(this%bndsvdesc(file_index_loc)%p) - end if - end if ! Do we write the variable? - - end subroutine write_horiz_coord_var - -!!####################################################################### -!! -!! CAM grid functions -!! -!!####################################################################### - - integer function get_cam_grid_index_char(gridname) - ! Dummy arguments - character(len=*), intent(in) :: gridname - ! Local variables - integer :: i - - get_cam_grid_index_char = -1 - do i = 1, registeredhgrids - if(trim(gridname) == trim(cam_grids(i)%name)) then - get_cam_grid_index_char = i - exit - end if - end do - - end function get_cam_grid_index_char - - integer function get_cam_grid_index_int(gridid) - ! Dummy arguments - integer, intent(in) :: gridid - ! Local variables - integer :: i - - get_cam_grid_index_int = -1 - do i = 1, registeredhgrids - if(gridid == cam_grids(i)%id) then - get_cam_grid_index_int = i - exit - end if - end do - - end function get_cam_grid_index_int - - subroutine find_cam_grid_attr(gridind, name, attr) - ! Dummy arguments - integer, intent(in) :: gridind - character(len=*), intent(in) :: name - class(cam_grid_attribute_t), pointer, intent(out) :: attr - ! Local variable - type(cam_grid_attr_ptr_t), pointer :: attrPtr - - nullify(attr) - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) -!!XXgoldyXX: Is this not working in PGI? -! attr => attrPtr%getAttr() - attr => attrPtr%attr - if (trim(name) == trim(attr%name)) then - exit - else -!!XXgoldyXX: Is this not working in PGI? -! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - nullify(attr) - end if - end do - return ! attr should be NULL if not found - end subroutine find_cam_grid_attr - - logical function cam_grid_attr_exists(gridname, name) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - ! Local variables - class(cam_grid_attribute_t), pointer :: attr - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, name, attr) - cam_grid_attr_exists = associated(attr) - nullify(attr) - else - call endrun('cam_grid_attr_exists: Bad grid name, "'//trim(gridname)//'"') - end if - end function cam_grid_attr_exists - - integer function num_cam_grid_attrs(gridind) - ! Dummy arguments - integer, intent(in) :: gridind - - ! Local variables - class(cam_grid_attr_ptr_t), pointer :: attrPtr - - num_cam_grid_attrs = 0 - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) - num_cam_grid_attrs = num_cam_grid_attrs + 1 -!!XXgoldyXX: Is this not working in PGI? -! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - end function num_cam_grid_attrs - - subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & - unstruct, block_indexed, zonal_grid, src_in, dest_in) - ! Dummy arguments - character(len=*), intent(in) :: name - integer, intent(in) :: id - type(horiz_coord_t), pointer, intent(in) :: lat_coord - type(horiz_coord_t), pointer, intent(in) :: lon_coord - integer(iMap), pointer, intent(in) :: map(:,:) - logical, optional, intent(in) :: unstruct - logical, optional, intent(in) :: block_indexed - logical, optional, intent(in) :: zonal_grid - integer, optional, intent(in) :: src_in(2) - integer, optional, intent(in) :: dest_in(2) - - ! Local variables - character(len=max_hcoordname_len) :: latdimname, londimname - character(len=120) :: errormsg - integer :: i - integer :: src(2), dest(2) - character(len=*), parameter :: subname = 'CAM_GRID_REGISTER' - - ! For a values grid, we do not allow multiple calls - if (get_cam_grid_index(trim(name)) > 0) then - call endrun(trim(subname)//': Grid, '//trim(name)//', already exists') - else if (get_cam_grid_index(id) > 0) then - i = get_cam_grid_index(id) - write(errormsg, '(4a,i5,3a)') trim(subname), ': Attempt to add grid, ', & - trim(name), ' with id = ', id, ', however, grid ', & - trim(cam_grids(i)%name), ' already has that ID' - call endrun(trim(errormsg)) - else if (registeredhgrids >= maxhgrids) then - call endrun(trim(subname)//": Too many grids") - else - registeredhgrids = registeredhgrids + 1 - cam_grids(registeredhgrids)%name = trim(name) - cam_grids(registeredhgrids)%id = id - ! Quick sanity checks to make sure these aren't mixed up - if (.not. lat_coord%latitude) then - call endrun(subname//': lat_coord is not a latitude coordinate') - end if - if (lon_coord%latitude) then - call endrun(subname//': lon_coord is not a longitude coordinate') - end if - cam_grids(registeredhgrids)%lat_coord => lat_coord - cam_grids(registeredhgrids)%lon_coord => lon_coord - call lat_coord%get_dim_name(latdimname) - call lon_coord%get_dim_name(londimname) - if (present(unstruct)) then - cam_grids(registeredhgrids)%unstructured = unstruct - else - if (trim(latdimname) == trim(londimname)) then - cam_grids(registeredhgrids)%unstructured = .true. - else - cam_grids(registeredhgrids)%unstructured = .false. - end if - end if - if (present(block_indexed)) then - cam_grids(registeredhgrids)%block_indexed = block_indexed - else - cam_grids(registeredhgrids)%block_indexed = cam_grids(registeredhgrids)%unstructured - end if - if (present(zonal_grid)) then - ! Check the size of the longitude coordinate - call lon_coord%get_coord_len(i) - if (i /= 1) then - call endrun(subname//': lon_coord is not of size 1 for a zonal grid') - end if - cam_grids(registeredhgrids)%zonal_grid = zonal_grid + end subroutine write_cam_grid_val_1d_int + + subroutine write_cam_grid_val_1d_r8(attr, File, file_index) + use pio, only: file_desc_t, pio_put_var, pio_double + use pio, only: pio_inq_varid, pio_write_darray + use pio, only: io_desc_t, pio_freedecomp + use cam_pio_utils, only: cam_pio_newdecomp + + ! Dummy arguments + class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr + type(file_desc_t), intent(inout) :: File + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: ierr + type(io_desc_t), pointer :: iodesc + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' + + if (present(file_index)) then + file_index_loc = file_index else - cam_grids(registeredhgrids)%zonal_grid = .false. + file_index_loc = 1 end if - if (associated(cam_grids(registeredhgrids)%map)) then - call endrun(trim(subname)//": new grid map should not be associated") + + nullify(iodesc) + ! Since more than one grid can share an attribute, assume that if the + ! vardesc is not associated, another grid write the values + if (associated(attr%vardesc(file_index_loc)%p)) then + ! Write out the values for this dimension variable + if (associated(attr%map)) then + ! This is a distributed variable, use pio_write_darray + allocate(iodesc) + call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & + pio_double) + call pio_write_darray(File, attr%vardesc(file_index_loc)%p, & + iodesc, attr%values, ierr) + call pio_freedecomp(File, iodesc) + deallocate(iodesc) + nullify(iodesc) + else + ! This is a local variable, pio_put_var should work fine + ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, & + attr%values) + end if + call cam_pio_handle_error(ierr, & + 'Error writing variable values in '//subname) + deallocate(attr%vardesc(file_index_loc)%p) + nullify(attr%vardesc(file_index_loc)%p) end if - if (present(src_in)) then - src = src_in + + end subroutine write_cam_grid_val_1d_r8 + + subroutine cam_grid_write_var(File, grid_id, file_index) + use pio, only: file_desc_t, pio_bcast_error, pio_seterrorhandling + + ! Dummy arguments + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: grid_id + integer, optional, intent(in) :: file_index + + ! Local variables + integer :: gridind + integer :: err_handling + class(cam_grid_attribute_t), pointer :: attr + type(cam_grid_attr_ptr_t), pointer :: attrPtr + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index else - src(1) = 1 - src(2) = -1 + file_index_loc = 1 end if - if (present(dest_in)) then - dest = dest_in - else - dest(1) = 1 - if (cam_grids(registeredhgrids)%unstructured) then - dest(2) = 0 - else - dest(2) = 2 - end if - end if - allocate(cam_grids(registeredhgrids)%map) - call cam_grids(registeredhgrids)%map%init(map, & - cam_grids(registeredhgrids)%unstructured, src, dest) - call cam_grids(registeredhgrids)%print_cam_grid() - end if - - end subroutine cam_grid_register - - subroutine print_cam_grid(this) - class(cam_grid_t) :: this - - type(cam_grid_attr_ptr_t), pointer :: attrPtr - class(cam_grid_attribute_t), pointer :: attr - if (masterproc) then - write(iulog, '(3a,i4,4a,3(a,l2))') 'Grid: ', trim(this%name), & - ', ID = ', this%id, & - ', lat coord = ', trim(this%lat_coord%name), & - ', lon coord = ', trim(this%lon_coord%name), & - ', unstruct = ', this%unstructured, & - ', block_ind = ', this%block_indexed, & - ', zonal_grid = ', this%zonal_grid - attrPtr => this%attributes - do while (associated(attrPtr)) -!!XXgoldyXX: Is this not working in PGI? -! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%print_attr() -!!XXgoldyXX: Is this not working in PGI? -! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do - end if - end subroutine print_cam_grid - - integer function cam_grid_num_grids() - cam_grid_num_grids = registeredhgrids - end function cam_grid_num_grids - - ! Return .true. iff id represents a valid CAM grid - logical function cam_grid_check(id) - ! Dummy argument - integer, intent(in) :: id - - cam_grid_check = ((get_cam_grid_index(id) > 0) .and. & - (get_cam_grid_index(id) <= cam_grid_num_grids())) - end function cam_grid_check - - integer function cam_grid_id(name) - ! Dummy argument - character(len=*), intent(in) :: name - - ! Local variable - integer :: index - - index = get_cam_grid_index(name) - if (index > 0) then - cam_grid_id = cam_grids(index)%id - else - cam_grid_id = -1 - end if - - end function cam_grid_id - - ! Return the size of a local array for grid, ID. - ! With no optional argument, return the basic 2D array size - ! nlev represents levels or the total column size (product(mdims)) - integer function cam_grid_get_local_size(id, nlev) - - ! Dummy arguments - integer, intent(in) :: id - integer, optional, intent(in) :: nlev - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - cam_grid_get_local_size = cam_grids(gridid)%num_elem() - if (present(nlev)) then - cam_grid_get_local_size = cam_grid_get_local_size * nlev - end if - else - write(errormsg, *) 'cam_grid_get_local_size: Bad grid ID, ', id - call endrun(errormsg) - end if - - end function cam_grid_get_local_size - - ! Given some array information, find the dimension NetCDF IDs on for this grid - subroutine cam_grid_get_file_dimids(id, File, dimids) - use pio, only: file_desc_t - - ! Dummy arguments - integer, intent(in) :: id - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(out) :: dimids(:) - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%find_dimids(File, dimids) - else - write(errormsg, *) 'cam_grid_get_file_dimids: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_get_file_dimids - - ! Given some array information, find or compute a PIO decomposition - subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, iodesc, & - field_dnames, file_dnames) - use pio, only: io_desc_t - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(in) :: field_lens(:) ! Array dim sizes - integer, intent(in) :: file_lens(:) ! File dim sizes - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - character(len=*), optional, intent(in) :: field_dnames(:) - character(len=*), optional, intent(in) :: file_dnames(:) - - ! Local variables - integer :: gridid - character(len=128) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%get_decomp(field_lens, file_lens, dtype, iodesc, & - field_dnames, file_dnames) - else - write(errormsg, *) 'cam_grid_get_decomp: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_get_decomp - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_2d_int - ! - ! Interface function for the grid%read_darray_2d_int method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_int(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_2d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_3d_int - ! - ! Interface function for the grid%read_darray_2d_ method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_int(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_3d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_2d_double - ! - ! Interface function for the grid%read_darray_2d_double method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_double(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_2d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_3d_double - ! - ! Interface function for the grid%read_darray_3d_double method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_double(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_3d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_2d_real - ! - ! Interface function for the grid%read_darray_2d_real method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_2d_real(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_2d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_2d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_dist_array_3d_real - ! - ! Interface function for the grid%read_darray_3d_real method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%read_darray_3d_real(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_read_dist_array_3d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_read_dist_array_3d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_2d_int - ! - ! Interface function for the grid%write_darray_2d_int method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_int(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_2d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_3d_int - ! - ! Interface function for the grid%write_darray_3d_int method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_int(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_3d_int: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_1d_double - ! - ! Interface function for the grid%write_darray_1d_double method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_1d_double(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_1d_double(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_1d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_1d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_2d_double - ! - ! Interface function for the grid%write_darray_2d_double method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_double(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_2d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_3d_double - ! - ! Interface function for the grid%write_darray_3d_double method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_double(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_3d_double: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_1d_real - ! - ! Interface function for the grid%write_darray_1d_real method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_1d_real(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - write(iulog,*) gridid - if (gridid > 0) then - call cam_grids(gridid)%write_darray_1d_real(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_1d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_1d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_2d_real - ! - ! Interface function for the grid%write_darray_2d_real method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - write(iulog,*) gridid - if (gridid > 0) then - call cam_grids(gridid)%write_darray_2d_real(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_2d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_2d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_dist_array_3d_real - ! - ! Interface function for the grid%write_darray_3d_real method - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, hbuf, varid) - use pio, only: file_desc_t - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: id - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variable - integer :: gridid - character(len=120) :: errormsg - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%write_darray_3d_real(File, adims, fdims, hbuf, varid) - else - write(errormsg, *) 'cam_grid_write_dist_array_3d_real: Bad grid ID, ', id - call endrun(errormsg) - end if - - end subroutine cam_grid_write_dist_array_3d_real - - subroutine cam_grid_get_gcid(id, gcid) - - ! Dummy arguments - integer, intent(in) :: id - integer(iMap), pointer :: gcid(:) - - ! Local variables - integer :: gridid - integer :: fieldbounds(2,2) - integer :: fieldlens(2) - integer :: filelens(2) - type(cam_filemap_t), pointer :: map - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - map => cam_grids(gridid)%map - call cam_grids(gridid)%coord_lengths(filelens) - call map%array_bounds(fieldbounds) - fieldlens(:) = fieldbounds(:,2) - fieldbounds(:,1) + 1 - call map%get_filemap(fieldlens, filelens, gcid) - else - call endrun('cam_grid_get_gcid: Bad grid ID') - end if - end subroutine cam_grid_get_gcid - - subroutine cam_grid_get_array_bounds(id, dims) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(inout) :: dims(:,:) - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_get_array_bounds: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - call cam_grids(gridid)%map%array_bounds(dims) - end if - else - call endrun('cam_grid_get_array_bounds: Bad grid ID') - end if - - end subroutine cam_grid_get_array_bounds - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_coord_names: Return the names of the grid axes - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_coord_names(id, lon_name, lat_name) - - ! Dummy arguments - integer, intent(in) :: id - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: lat_name - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%coord_names(lon_name, lat_name) - else - call endrun('cam_grid_get_coord_names: Bad grid ID') - end if - - end subroutine cam_grid_get_coord_names - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_dim_names: Return the names of the grid axes dimensions. - ! Note that these may be the same - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_dim_names_id(id, name1, name2) - - ! Dummy arguments - integer, intent(in) :: id - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%dim_names(name1, name2) - else - call endrun('cam_grid_get_dim_names_id: Bad grid ID') - end if - - end subroutine cam_grid_get_dim_names_id - - subroutine cam_grid_get_dim_names_name(gridname, name1, name2) - - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - ! Local variables - integer :: gridind - character(len=120) :: errormsg - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind < 0) then - write(errormsg, *) 'No CAM grid with name = ', trim(gridname) - call endrun('cam_grid_get_dim_names_name: '//errormsg) - else - call cam_grids(gridind)%dim_names(name1, name2) - end if - - end subroutine cam_grid_get_dim_names_name - - logical function cam_grid_has_blocksize(id) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_has_blocksize: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - cam_grid_has_blocksize = cam_grids(gridid)%map%has_blocksize() - end if - else - call endrun('cam_grid_has_blocksize: Bad grid ID') - end if - end function cam_grid_has_blocksize - - ! Return the number of active columns in the block specified by block_id - integer function cam_grid_get_block_count(id, block_id) result(ncol) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(in) :: block_id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%map)) then - call endrun('cam_grid_get_block_count: Grid, '//trim(cam_grids(gridid)%name)//', has no map') - else - ncol = cam_grids(gridid)%map%blocksize(block_id) + gridind = get_cam_grid_index(grid_id) + ! Only write if not already done + if (cam_grids(gridind)%attrs_defined(file_index_loc)) then + ! Write the horizontal coorinate values + call cam_grids(gridind)%lon_coord%write_var(File, file_index) + call cam_grids(gridind)%lat_coord%write_var(File, file_index) + + ! We will handle errors for this routine + call pio_seterrorhandling(File, PIO_BCAST_ERROR, & + oldmethod=err_handling) + + ! Write out the variable values for each grid attribute + attrPtr => cam_grids(gridind)%attributes + do while (associated(attrPtr)) + !!XXgoldyXX: Is this not working in PGI? + ! attr => attrPtr%getAttr() + attr => attrPtr%attr + call attr%write_val(File, file_index=file_index_loc) + !!XXgoldyXX: Is this not working in PGI? + ! attrPtr => attrPtr%getNext() + attrPtr => attrPtr%next + end do + + ! Back to previous I/O error handling + call pio_seterrorhandling(File, err_handling) + + cam_grids(gridind)%attrs_defined(file_index_loc) = .false. end if - else - call endrun('cam_grid_get_block_count: Bad grid ID') - end if - end function cam_grid_get_block_count - function cam_grid_get_latvals(id) result(latvals) + end subroutine cam_grid_write_var + + logical function cam_grid_block_indexed(this) + class(cam_grid_t) :: this + + cam_grid_block_indexed = this%block_indexed + end function cam_grid_block_indexed + + logical function cam_grid_zonal_grid(this) + class(cam_grid_t) :: this + + cam_grid_zonal_grid = this%zonal_grid + end function cam_grid_zonal_grid + + logical function cam_grid_unstructured(this) + class(cam_grid_t) :: this + + cam_grid_unstructured = this%unstructured + end function cam_grid_unstructured - ! Dummy argument - integer, intent(in) :: id - real(r8), pointer :: latvals(:) + !------------------------------------------------------------------------ + ! + ! cam_grid_get_dims: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_dims(this, dims) + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(inout) :: dims(2) - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%lat_coord%values)) then - nullify(latvals) + if (this%is_unstructured()) then + call this%lon_coord%get_coord_len(dims(1)) + dims(2) = 1 else - latvals => cam_grids(gridid)%lat_coord%values + call this%lon_coord%get_coord_len(dims(1)) + call this%lat_coord%get_coord_len(dims(2)) end if - else - call endrun('cam_grid_get_latvals: Bad grid ID') - end if - end function cam_grid_get_latvals - - function cam_grid_get_lonvals(id) result(lonvals) - ! Dummy arguments - integer, intent(in) :: id - real(r8), pointer :: lonvals(:) + end subroutine cam_grid_get_dims - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - if (.not. associated(cam_grids(gridid)%lon_coord%values)) then - nullify(lonvals) + !------------------------------------------------------------------------ + ! + ! cam_grid_coord_names: Return the names of the grid axes + ! + !------------------------------------------------------------------------ + subroutine cam_grid_coord_names(this, lon_name, lat_name) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: lat_name + + call this%lon_coord%get_coord_name(lon_name) + call this%lat_coord%get_coord_name(lat_name) + + end subroutine cam_grid_coord_names + + !------------------------------------------------------------------------ + ! + ! cam_grid_dim_names: Return the names of the dimensions of the + ! grid axes. + ! Note that these may be the same + ! + !------------------------------------------------------------------------ + subroutine cam_grid_dim_names(this, name1, name2) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(out) :: name1 + character(len=*), intent(out) :: name2 + + call this%lon_coord%get_dim_name(name1) + call this%lat_coord%get_dim_name(name2) + + end subroutine cam_grid_dim_names + + !------------------------------------------------------------------------ + ! + ! cam_grid_dimensions_id: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !------------------------------------------------------------------------ + subroutine cam_grid_dimensions_id(gridid, dims, rank) + ! Dummy arguments + integer, intent(in) :: gridid + integer, intent(inout) :: dims(2) + integer, optional, intent(out) :: rank + + ! Local variables + integer :: index + character(len=max_hcoordname_len) :: dname1, dname2 + character(len=120) :: errormsg + + index = get_cam_grid_index(gridid) + if (index < 0) then + write(errormsg, *) 'No CAM grid with ID =', gridid + call endrun(errormsg) else - lonvals => cam_grids(gridid)%lon_coord%values - end if - else - call endrun('cam_grid_get_lonvals: Bad grid ID') - end if - end function cam_grid_get_lonvals - - function cam_grid_get_areawt(id) result(wtvals) - - ! Dummy argument - integer, intent(in) :: id - real(r8), pointer :: wtvals(:) - - ! Local variables - character(len=max_chars) :: wtname - integer :: gridind - class(cam_grid_attribute_t), pointer :: attrptr - character(len=120) :: errormsg - - nullify(attrptr) - gridind = get_cam_grid_index(id) - if (gridind > 0) then - select case(cam_grids(gridind)%name) - case('GLL') - wtname='area_weight_gll' - case('EUL') - wtname='gw' - case('FV') - wtname='gw' - case('INI') - wtname='area_weight_ini' - case('physgrid') - wtname='areawt' - case('FVM') - wtname='area_weight_fvm' - case('mpas_cell') - wtname='area_weight_mpas' - case default - call endrun('cam_grid_get_areawt: Invalid gridname:'//trim(cam_grids(gridind)%name)) - end select - - call find_cam_grid_attr(gridind, trim(wtname), attrptr) - if (.not.associated(attrptr)) then - write(errormsg, '(4a)') & - 'cam_grid_get_areawt: error retrieving weight attribute ', trim(wtname), & - ' for cam grid ', cam_grids(gridind)%name - call endrun(errormsg) - else - call attrptr%print_attr() - select type(attrptr) - type is (cam_grid_attribute_1d_r8_t) - wtvals => attrptr%values - class default - call endrun('cam_grid_get_areawt: wt attribute is not a real datatype') - end select - end if - end if - - end function cam_grid_get_areawt - - ! Find the longitude and latitude of a range of map entries - ! beg and end are the range of the first source index. blk is a block or chunk index - subroutine cam_grid_get_coords(id, beg, end, blk, lon, lat) - - ! Dummy arguments - integer, intent(in) :: id - integer, intent(in) :: beg - integer, intent(in) :: end - integer, intent(in) :: blk - real(r8), intent(inout) :: lon(:) - real(r8), intent(inout) :: lat(:) - - ! Local variables - integer :: gridid - integer :: i - gridid = get_cam_grid_index(id) - if (gridid > 0) then - do i = beg, end - if (cam_grids(gridid)%is_unstructured()) then - call endrun('cam_grid_get_coords: Not implemented') - else - call endrun('cam_grid_get_coords: Not implemented') - end if - end do - else - call endrun('cam_grid_get_coords: Bad grid ID') - end if - end subroutine cam_grid_get_coords - - logical function cam_grid_is_unstructured(id) result(unstruct) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - unstruct = cam_grids(gridid)%is_unstructured() - else - call endrun('cam_grid_is_unstructured: Bad grid ID') - end if - end function cam_grid_is_unstructured - - logical function cam_grid_is_block_indexed(id) result(block_indexed) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - block_indexed = cam_grids(gridid)%is_block_indexed() - else - call endrun('s: Bad grid ID') - end if - end function cam_grid_is_block_indexed - - logical function cam_grid_is_zonal(id) result(zonal) - - ! Dummy arguments - integer, intent(in) :: id - - ! Local variables - integer :: gridid - gridid = get_cam_grid_index(id) - if (gridid > 0) then - zonal = cam_grids(gridid)%is_zonal_grid() - else - call endrun('s: Bad grid ID') - end if - end function cam_grid_is_zonal - - ! Compute or update a grid patch mask - subroutine cam_grid_compute_patch(id, patch, lonl, lonu, latl, latu, cco) - - ! Dummy arguments - integer, intent(in) :: id - type(cam_grid_patch_t), intent(inout) :: patch - real(r8), intent(in) :: lonl - real(r8), intent(in) :: lonu - real(r8), intent(in) :: latl - real(r8), intent(in) :: latu - logical, intent(in) :: cco ! Collect columns? - - ! Local variables - integer :: gridid - - gridid = get_cam_grid_index(id) - if (gridid > 0) then - call cam_grids(gridid)%get_patch_mask(lonl, lonu, latl, latu, patch, cco) - else - call endrun('cam_grid_compute_patch: Bad grid ID') - end if - - end subroutine cam_grid_compute_patch - -!!####################################################################### -!! -!! CAM grid attribute functions -!! -!!####################################################################### - - subroutine cam_grid_attr_init(this, name, long_name, next) - ! Dummy arguments - class(cam_grid_attribute_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - class(cam_grid_attribute_t), pointer :: next - - this%name = trim(name) - this%long_name = trim(long_name) - this%next => next - end subroutine cam_grid_attr_init - - subroutine print_attr_base(this) - ! Dummy arguments - class(cam_grid_attribute_t), intent(in) :: this - if (masterproc) then - write(iulog, '(5a)') 'Attribute: ', trim(this%name), ", long name = '", & - trim(this%long_name), "'" - end if - end subroutine print_attr_base - - subroutine cam_grid_attr_init_0d_int(this, name, long_name, val) - ! Dummy arguments - class(cam_grid_attribute_0d_int_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - integer, intent(in) :: val - -! call this%cam_grid_attr_init(name, '') - this%name = trim(name) - this%long_name = trim(long_name) - this%ival = val - end subroutine cam_grid_attr_init_0d_int - - subroutine print_attr_0d_int(this) - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(in) :: this - - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' value = ', this%ival - end if - end subroutine print_attr_0d_int - - subroutine cam_grid_attr_init_0d_char(this, name, long_name, val) - ! Dummy arguments - class(cam_grid_attribute_0d_char_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: val - -! call this%cam_grid_attr_init(name, '') - this%name = trim(name) - this%long_name = trim(long_name) - this%val = trim(val) - end subroutine cam_grid_attr_init_0d_char - - subroutine print_attr_0d_char(this) - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(in) :: this - - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' value = ', trim(this%val) - end if - end subroutine print_attr_0d_char - - subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & - dimsize, values, map) - ! Dummy arguments - class(cam_grid_attribute_1d_int_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - integer, target, intent(in) :: values(:) - integer(iMap), optional, target, intent(in) :: map(:) - -! call this%cam_grid_attr_init(trim(name), trim(long_name)) - if (len_trim(name) > max_hcoordname_len) then - call endrun('cam_grid_attr_1d_int: name too long') - end if - this%name = trim(name) - if (len_trim(long_name) > max_chars) then - call endrun('cam_grid_attr_1d_int: long_name too long') - end if - this%long_name = trim(long_name) - - if (len_trim(dimname) > max_hcoordname_len) then - call endrun('cam_grid_attr_1d_int: dimname too long') - end if - this%dimname = trim(dimname) - this%dimsize = dimsize - this%values => values - ! Fill in the optional map - if (present(map)) then - allocate(this%map(size(map))) - this%map(:) = map(:) - else - nullify(this%map) - end if - end subroutine cam_grid_attr_init_1d_int - - subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & - dimsize, values, map) - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t) :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in) :: dimsize - real(r8), target, intent(in) :: values(:) - integer(iMap), optional, target, intent(in) :: map(:) - -! call this%cam_grid_attr_init(trim(name), trim(long_name), next) - this%name = trim(name) - this%long_name = trim(long_name) - - this%dimname = trim(dimname) - this%dimsize = dimsize - this%values => values - ! Fill in the optional map - if (present(map)) then - allocate(this%map(size(map))) - this%map(:) = map(:) - else - nullify(this%map) - end if - end subroutine cam_grid_attr_init_1d_r8 - - subroutine print_attr_1d_int(this) - ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(in) :: this - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' dimname = ', trim(this%dimname) - end if - end subroutine print_attr_1d_int - - subroutine print_attr_1d_r8(this) - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(in) :: this - call this%print_attr_base() - if (masterproc) then - write(iulog, *) ' dimname = ', trim(this%dimname) - end if - end subroutine print_attr_1d_r8 - - subroutine insert_grid_attribute(gridind, attr) - integer, intent(in) :: gridind - class(cam_grid_attribute_t), pointer :: attr - - ! Push a new attribute onto the grid - type(cam_grid_attr_ptr_t), pointer :: attrPtr - - allocate(attrPtr) - call attrPtr%initialize(attr) - call attrPtr%setNext(cam_grids(gridind)%attributes) - cam_grids(gridind)%attributes => attrPtr - call attrPtr%attr%print_attr() - end subroutine insert_grid_attribute - - subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - integer, intent(in) :: val - - ! Local variables - type(cam_grid_attribute_0d_int_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_0d_int: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) + call cam_grids(index)%coord_lengths(dims) + end if + if (present(rank)) then + call cam_grids(index)%dim_names(dname1, dname2) + if (trim(dname1) == trim(dname2)) then + rank = 1 + else + rank = 2 + end if + end if + + end subroutine cam_grid_dimensions_id + + !------------------------------------------------------------------------ + ! + ! cam_grid_dimensions_name: Return the dimensions of the grid + ! For lon/lat grids, this is (nlon, nlat) + ! For unstructured grids, this is (ncols, 1) + ! + !------------------------------------------------------------------------ + subroutine cam_grid_dimensions_name(gridname, dims, rank) + ! Dummy arguments + character(len=*), intent(in) :: gridname + integer, intent(inout) :: dims(2) + integer, optional, intent(out) :: rank + + ! Local variables + integer :: gridind + character(len=max_hcoordname_len) :: dname1, dname2 + character(len=120) :: errormsg + + gridind = get_cam_grid_index(trim(gridname)) + if (gridind < 0) then + write(errormsg, *) 'No CAM grid with name = ', trim(gridname) + call endrun(errormsg) else - ! Need a new attribute. - allocate(attr) - call attr%cam_grid_attr_init_0d_int(trim(name), trim(long_name), val) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_int: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if -! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_0d_int - - subroutine add_cam_grid_attribute_0d_char(gridname, name, val) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: val - - ! Local variables - type(cam_grid_attribute_0d_char_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_0d_char: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) + call cam_grids(gridind)%coord_lengths(dims) + end if + if (present(rank)) then + call cam_grids(gridind)%dim_names(dname1, dname2) + if (trim(dname1) == trim(dname2)) then + rank = 1 + else + rank = 2 + end if + end if + + end subroutine cam_grid_dimensions_name + + !------------------------------------------------------------------------ + ! + ! cam_grid_set_map: Set a grid's distribution map + ! This maps the local grid elements to global file order + ! + !------------------------------------------------------------------------ + subroutine cam_grid_set_map(this, map, src, dest) + use spmd_utils, only: mpicom + use mpi, only: mpi_sum, mpi_integer + ! Dummy arguments + class(cam_grid_t) :: this + integer(iMap), pointer :: map(:,:) + integer, intent(in) :: src(2) ! decomp info + integer, intent(in) :: dest(2) ! Standard dim(s) in file + + ! Local variables + integer :: dims(2) + integer :: dstrt, dend + integer :: gridlen, gridloc, ierr + + ! Check to make sure the map meets our needs + call this%coord_lengths(dims) + dend = size(map, 1) + ! We always have to have one source and one destination + if (dest(2) > 0) then + dstrt = dend - 1 else - ! Need a new attribute. - allocate(attr) - call attr%cam_grid_attr_init_0d_char(trim(name), '', val) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_0d_char: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if -! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_0d_char - - subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & - dimname, values, map) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - integer, intent(in), target :: values(:) - integer(iMap), intent(in), target, optional :: map(:) - - ! Local variables - type(cam_grid_attribute_1d_int_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - integer :: dimsize - - nullify(attr) - nullify(attptr) - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_1d_int: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) + dstrt = dend + end if + if ((src(2) /= 0) .and. (dstrt < 3)) then + call endrun('cam_grid_set_map: src & dest too large for map') + else if (dstrt < 2) then + call endrun('cam_grid_set_map: dest too large for map') + ! No else needed + end if + if (dstrt == dend) then + gridloc = count(map(dend,:) /= 0) else - ! Need a new attribute. - dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) - if (dimsize < 1) then - dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) - end if - if (dimsize < 1) then - write(errormsg, *) 'add_cam_grid_attribute_1d_int: attribute ', & - 'dimension ', trim(dimname), ' for ', trim(name), ', not found' - call endrun(errormsg) - end if - allocate(attr) - call attr%cam_grid_attr_init_1d_int(trim(name), trim(long_name), & - trim(dimname), dimsize, values, map) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_int: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if -! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_1d_int - - subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & - dimname, values, map) - ! Dummy arguments - character(len=*), intent(in) :: gridname - character(len=*), intent(in) :: name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: dimname - real(r8), intent(in), target :: values(:) - integer(iMap), intent(in), target, optional :: map(:) - - ! Local variables - type(cam_grid_attribute_1d_r8_t), pointer :: attr - class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg - integer :: gridind - integer :: dimsize - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind > 0) then - call find_cam_grid_attr(gridind, trim(name), attptr) - if (associated(attptr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') & - 'add_cam_grid_attribute_1d_r8: attribute ', trim(name), & - ' already exists for ', cam_grids(gridind)%name - call endrun(errormsg) + gridloc = count((map(dstrt,:) /= 0) .and. (map(dend,:) /= 0)) + end if + call MPI_Allreduce(gridloc, gridlen, 1, MPI_INTEGER, MPI_SUM, & + mpicom, ierr) + if (gridlen /= product(dims)) then + call endrun('cam_grid_set_map: Bad map size for '//trim(this%name)) else - ! Need a new attribute. - dimsize = cam_grids(gridind)%lat_coord%global_size(trim(dimname)) - if (dimsize < 1) then - dimsize = cam_grids(gridind)%lon_coord%global_size(trim(dimname)) - end if - if (dimsize < 1) then - write(errormsg, *) 'add_cam_grid_attribute_1d_r8: attribute ', & - 'dimension ', trim(dimname), ' for ', trim(name), ', not found' - call endrun(errormsg) - end if - allocate(attr) - call attr%cam_grid_attr_init_1d_r8(trim(name), trim(long_name), & - trim(dimname), dimsize, values, map) - attptr => attr - call insert_grid_attribute(gridind, attptr) - end if - else - write(errormsg, '(3a)') 'add_cam_grid_attribute_1d_r8: grid ', & - trim(gridname), ' was not found' - call endrun(errormsg) - end if -! call cam_grids(gridind)%print_cam_grid() - end subroutine add_cam_grid_attribute_1d_r8 - -!!####################################################################### -!! -!! CAM grid attribute pointer (list node) functions -!! -!!####################################################################### - - subroutine initializeAttrPtr(this, attr) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - class(cam_grid_attribute_t), target :: attr - - if (associated(this%next)) then - if (masterproc) then - write(iulog, *) 'WARNING: Overwriting attr pointer for cam_grid_attr_ptr_t' + if (.not. associated(this%map)) then + allocate(this%map) + end if + call this%map%init(map, this%unstructured, src, dest) end if - end if - this%attr => attr - end subroutine initializeAttrPtr + end subroutine cam_grid_set_map - function getAttrPtrAttr(this) - ! Dummy variable - class(cam_grid_attr_ptr_t) :: this - class(cam_grid_attribute_t), pointer :: getAttrPtrAttr + !------------------------------------------------------------------------ + ! + ! cam_grid_local_size: return the local size of a 2D array on this grid + ! + !------------------------------------------------------------------------ + integer function cam_grid_local_size(this) - getAttrPtrAttr => this%attr - end function getAttrPtrAttr + ! Dummy argument + class(cam_grid_t) :: this - function getAttrPtrNext(this) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - type(cam_grid_attr_ptr_t), pointer :: getAttrPtrNext + ! Local variable + character(len=128) :: errormsg - getAttrPtrNext => this%next - end function getAttrPtrNext + if (.not. associated(this%map)) then + write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' + call endrun('cam_grid_local_size: '//trim(errormsg)) + else + cam_grid_local_size = this%map%num_elem() + end if - subroutine setAttrPtrNext(this, next) - ! Dummy arguments - class(cam_grid_attr_ptr_t) :: this - type(cam_grid_attr_ptr_t), pointer :: next + end function cam_grid_local_size - if (associated(this%next)) then - if (masterproc) then - write(iulog, *) 'WARNING: Overwriting next pointer for cam_grid_attr_ptr_t' - end if - end if - this%next => next - end subroutine setAttrPtrNext - - !--------------------------------------------------------------------------- - ! - ! write_cam_grid_attr_0d_int - ! - ! Write a grid attribute - ! - !--------------------------------------------------------------------------- - - subroutine write_cam_grid_attr_0d_int(attr, File, file_index) - use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, & - pio_inq_att, PIO_GLOBAL - use cam_pio_utils, only: cam_pio_def_var - - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: attrtype - integer(imap) :: attrlen - integer :: ierr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc(file_index_loc)%p)) then - if (len_trim(attr%long_name) > 0) then - ! This 0d attribute is a scalar variable with a long_name attribute - ! First, define the variable - allocate(attr%vardesc(file_index_loc)%p) - call cam_pio_def_var(File, trim(attr%name), pio_int, attr%vardesc(file_index_loc)%p, & - existOK=.false.) - ierr=pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) - call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_0d_int') - else - ! This 0d attribute is a global attribute - ! Check to see if the attribute already exists in the file - ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) - if (ierr /= PIO_NOERR) then - ! Time to define the attribute - ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%ival) - call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_int') - end if - end if - end if - - end subroutine write_cam_grid_attr_0d_int - - !--------------------------------------------------------------------------- - ! - ! write_cam_grid_attr_0d_char - ! - ! Write a grid attribute - ! - !--------------------------------------------------------------------------- - - subroutine write_cam_grid_attr_0d_char(attr, File, file_index) - use pio, only: file_desc_t, pio_put_att, pio_noerr, & - pio_inq_att, PIO_GLOBAL - - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: attrtype - integer(imap) :: attrlen - integer :: ierr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc(file_index_loc)%p)) then - ! The 0d char attributes are global attribues - ! Check to see if the attribute already exists in the file - ierr = pio_inq_att(File, PIO_GLOBAL, attr%name, attrtype, attrlen) - if (ierr /= PIO_NOERR) then - ! Time to define the variable - ierr = pio_put_att(File, PIO_GLOBAL, trim(attr%name), attr%val) - call cam_pio_handle_error(ierr, 'Unable to define attribute in write_cam_grid_attr_0d_char') - end if - end if - - end subroutine write_cam_grid_attr_0d_char - - !--------------------------------------------------------------------------- - ! - ! write_cam_grid_attr_1d_int - ! - ! Write a grid attribute - ! - !--------------------------------------------------------------------------- - - subroutine write_cam_grid_attr_1d_int(attr, File, file_index) - use pio, only: file_desc_t, pio_put_att, pio_noerr - use pio, only: pio_inq_dimid, pio_int - use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile - - ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: dimid ! PIO dimension ID - character(len=120) :: errormsg - integer :: ierr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc(file_index_loc)%p)) then - ! Check to see if the dimension already exists in the file - ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) - if (ierr /= PIO_NOERR) then - ! The dimension has not yet been defined. This is an error - ! NB: It should have been defined as part of a coordinate - write(errormsg, *) 'write_cam_grid_attr_1d_int: dimension, ', & - trim(attr%dimname), ', does not exist' - call cam_pio_closefile(File) - call endrun(errormsg) - end if - ! Time to define the variable - allocate(attr%vardesc(file_index_loc)%p) - call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), & - attr%vardesc(file_index_loc)%p, existOK=.false.) - ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) - call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_int') - end if - - end subroutine write_cam_grid_attr_1d_int - - !--------------------------------------------------------------------------- - ! - ! write_cam_grid_attr_1d_r8 - ! - ! Write a grid attribute - ! - !--------------------------------------------------------------------------- - - subroutine write_cam_grid_attr_1d_r8(attr, File, file_index) - use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double, & - pio_inq_dimid - use cam_pio_utils, only: cam_pio_def_var, cam_pio_closefile - - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: dimid ! PIO dimension ID - character(len=120) :: errormsg - integer :: ierr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is associated, that grid defined the attribute - if (.not. associated(attr%vardesc(file_index_loc)%p)) then - ! Check to see if the dimension already exists in the file - ierr = pio_inq_dimid(File, trim(attr%dimname), dimid) - if (ierr /= PIO_NOERR) then - ! The dimension has not yet been defined. This is an error - ! NB: It should have been defined as part of a coordinate - write(errormsg, *) 'write_cam_grid_attr_1d_r8: dimension, ', & - trim(attr%dimname), ', does not exist' - call cam_pio_closefile(File) - call endrun(errormsg) - end if - ! Time to define the variable - allocate(attr%vardesc(file_index_loc)%p) - call cam_pio_def_var(File, trim(attr%name), pio_double, (/dimid/), & - attr%vardesc(file_index_loc)%p, existOK=.false.) - ! long_name - ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, 'long_name', trim(attr%long_name)) - call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_r8') - end if - - end subroutine write_cam_grid_attr_1d_r8 - - !--------------------------------------------------------------------------- - ! - ! cam_grid_attribute_copy - ! - ! Copy an attribute from a source grid to a destination grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name) - ! Dummy arguments - character(len=*), intent(in) :: src_grid - character(len=*), intent(in) :: dest_grid - character(len=*), intent(in) :: attribute_name - - ! Local variables - character(len=120) :: errormsg - integer :: src_ind, dest_ind - class(cam_grid_attribute_t), pointer :: attr - - ! Find the source and destination grid indices - src_ind = get_cam_grid_index(trim(src_grid)) - dest_ind = get_cam_grid_index(trim(dest_grid)) - - call find_cam_grid_attr(dest_ind, trim(attribute_name), attr) - if (associated(attr)) then - ! Attribute found, can't add it again! - write(errormsg, '(4a)') 'CAM_GRID_ATTRIBUTE_COPY: attribute ', & - trim(attribute_name),' already exists for ',cam_grids(dest_ind)%name - call endrun(errormsg) - else - call find_cam_grid_attr(src_ind, trim(attribute_name), attr) - if (associated(attr)) then - ! Copy the attribute - call insert_grid_attribute(dest_ind, attr) + !------------------------------------------------------------------------ + ! + ! cam_grid_get_lon_lat: Find the latitude and longitude for a given + ! grid map index. Note if point is not mapped + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_lon_lat(this, index, lon, lat, isMapped) + + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(in) :: index + real(r8), intent(out) :: lon + real(r8), intent(out) :: lat + logical, intent(out) :: isMapped + + ! Local variables + integer :: latindex, lonindex + character(len=*), parameter :: subname = "cam_grid_get_lon_lat" + + if (this%block_indexed) then + lonindex = index + latindex = index + isMapped = this%map%is_mapped(index) else - write(errormsg, '(4a)') ": Did not find attribute, '", & - trim(attribute_name), "' in ", cam_grids(src_ind)%name - call endrun("CAM_GRID_ATTRIBUTE_COPY"//errormsg) - end if - end if - - end subroutine cam_grid_attribute_copy - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_attr - ! - ! Write the dimension and coordinate attributes for the horizontal history - ! coordinates. - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_attr(File, grid_id, header_info, file_index) - use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, intent(in) :: grid_id - type(cam_grid_header_info_t), intent(inout) :: header_info - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: gridind - class(cam_grid_attribute_t), pointer :: attr - type(cam_grid_attr_ptr_t), pointer :: attrPtr - integer :: dimids(2) - integer :: err_handling - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - gridind = get_cam_grid_index(grid_id) - !! Fill this in to make sure history finds grid - header_info%grid_id = grid_id - - if (allocated(header_info%hdims)) then - deallocate(header_info%hdims) - end if - - if (associated(header_info%lon_varid)) then - ! This could be a sign of bad memory management - call endrun('CAM_GRID_WRITE_ATTR: lon_varid should be NULL') - end if - if (associated(header_info%lat_varid)) then - ! This could be a sign of bad memory management - call endrun('CAM_GRID_WRITE_ATTR: lat_varid should be NULL') - end if - - ! Only write this grid if not already defined - if (cam_grids(gridind)%attrs_defined(file_index_loc)) then - ! We need to fill out the hdims info for this grid - call cam_grids(gridind)%find_dimids(File, dimids) - if (dimids(2) < 0) then - allocate(header_info%hdims(1)) - header_info%hdims(1) = dimids(1) + call this%map%coord_vals(index, lonindex, latindex, isMapped) + end if + + !!XXgoldyXX: May be able to relax all the checks + if ( (latindex < LBOUND(this%lat_coord%values, 1)) .or. & + (latindex > UBOUND(this%lat_coord%values, 1))) then + call endrun(trim(subname)//": index out of range for latvals") else - allocate(header_info%hdims(2)) - header_info%hdims(1:2) = dimids(1:2) + lat = this%lat_coord%values(latindex) end if - else - ! Write the horizontal coord attributes first so that we have the dims - call cam_grids(gridind)%lat_coord%write_attr(File, dimids(2), file_index=file_index_loc) - call cam_grids(gridind)%lon_coord%write_attr(File, dimids(1), file_index=file_index_loc) - if (dimids(2) == dimids(1)) then - allocate(header_info%hdims(1)) + if ( (lonindex < LBOUND(this%lon_coord%values, 1)) .or. & + (lonindex > UBOUND(this%lon_coord%values, 1))) then + call endrun(trim(subname)//": index out of range for lonvals") else - allocate(header_info%hdims(2)) - header_info%hdims(2) = dimids(2) + lon = this%lon_coord%values(lonindex) end if - header_info%hdims(1) = dimids(1) - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) + end subroutine cam_grid_get_lon_lat - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) -!!XXgoldyXX: Is this not working in PGI? -! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%write_attr(File, file_index=file_index_loc) -!!XXgoldyXX: Is this not working in PGI? -! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next + !------------------------------------------------------------------------ + ! + ! cam_grid_find_src_dims: Find the correct src array dims for this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_find_src_dims(this, field_dnames, src_out) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(in) :: field_dnames(:) + integer, pointer :: src_out(:) + + ! Local variables + integer :: i, j + integer :: num_coords + character(len=max_hcoordname_len) :: coord_dimnames(2) + + call this%dim_names(coord_dimnames(1), coord_dimnames(2)) + if (associated(src_out)) then + deallocate(src_out) + nullify(src_out) + end if + if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then + num_coords = 1 + else + num_coords = 2 + end if + allocate(src_out(2)) ! Currently, all cases have two source dims + do i = 1, num_coords + do j = 1, size(field_dnames) + if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then + src_out(i) = j + end if + end do end do + if (num_coords < 2) then + src_out(2) = -1 ! Assume a block structure for unstructured grids + end if - ! Back to previous I/O error handling - call pio_seterrorhandling(File, err_handling) - cam_grids(gridind)%attrs_defined(file_index_loc) = .true. - end if - - end subroutine cam_grid_write_attr - - subroutine write_cam_grid_val_0d_int(attr, File, file_index) - use pio, only: file_desc_t, pio_put_var - - ! Dummy arguments - class(cam_grid_attribute_0d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: ierr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - ! We only write this var if it is a variable - if (associated(attr%vardesc(file_index_loc)%p)) then - ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%ival) - call cam_pio_handle_error(ierr, 'Error writing value in write_cam_grid_val_0d_int') - deallocate(attr%vardesc(file_index_loc)%p) - nullify(attr%vardesc(file_index_loc)%p) - end if - - end subroutine write_cam_grid_val_0d_int - - subroutine write_cam_grid_val_0d_char(attr, File, file_index) - use pio, only: file_desc_t - - ! Dummy arguments - class(cam_grid_attribute_0d_char_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - integer, optional, intent(in) :: file_index - - ! This subroutine is a stub because global attributes are written - ! in define mode - return - end subroutine write_cam_grid_val_0d_char - - subroutine write_cam_grid_val_1d_int(attr, File, file_index) - use pio, only: file_desc_t, pio_put_var, pio_int, & - pio_write_darray, io_desc_t, pio_freedecomp - use cam_pio_utils, only: cam_pio_newdecomp - - ! Dummy arguments - class(cam_grid_attribute_1d_int_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: ierr - type(io_desc_t), pointer :: iodesc - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - nullify(iodesc) - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is not associated, another grid write the values - if (associated(attr%vardesc(file_index_loc)%p)) then - ! Write out the values for this dimension variable - if (associated(attr%map)) then - ! This is a distributed variable, use pio_write_darray - allocate(iodesc) - call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_int) - call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr) - call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) + end subroutine cam_grid_find_src_dims + + !------------------------------------------------------------------------ + ! + ! cam_grid_find_dest_dims: Find the correct file array dims for this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) + ! Dummy arguments + class(cam_grid_t) :: this + character(len=*), intent(in) :: file_dnames(:) + integer, pointer :: dest_out(:) + + ! Local variables + integer :: i, j + integer :: num_coords + character(len=max_hcoordname_len) :: coord_dimnames(2) + + call this%dim_names(coord_dimnames(1), coord_dimnames(2)) + if (associated(dest_out)) then + deallocate(dest_out) + nullify(dest_out) + end if + if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then + num_coords = 1 else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values) - end if - call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_int') - deallocate(attr%vardesc(file_index_loc)%p) - nullify(attr%vardesc(file_index_loc)%p) - end if - - end subroutine write_cam_grid_val_1d_int - - subroutine write_cam_grid_val_1d_r8(attr, File, file_index) - use pio, only: file_desc_t, pio_put_var, pio_double, & - pio_write_darray, io_desc_t, pio_freedecomp - use cam_pio_utils, only: cam_pio_newdecomp - - ! Dummy arguments - class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr - type(file_desc_t), intent(inout) :: File - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: ierr - type(io_desc_t), pointer :: iodesc - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - - nullify(iodesc) - ! Since more than one grid can share an attribute, assume that if the - ! vardesc is not associated, another grid write the values - if (associated(attr%vardesc(file_index_loc)%p)) then - ! Write out the values for this dimension variable - if (associated(attr%map)) then - ! This is a distributed variable, use pio_write_darray - allocate(iodesc) - call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_double) - call pio_write_darray(File, attr%vardesc(file_index_loc)%p, iodesc, attr%values, ierr) - call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) + num_coords = 2 + end if + allocate(dest_out(num_coords)) + dest_out = 0 + do i = 1, num_coords + do j = 1, size(file_dnames) + if (trim(file_dnames(j)) == trim(coord_dimnames(i))) then + dest_out(i) = j + end if + end do + end do + + end subroutine cam_grid_find_dest_dims + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_pio_decomp: Find or create a PIO decomp on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & + iodesc, field_dnames, file_dnames) + use pio, only: io_desc_t + use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation + + ! Dummy arguments + class(cam_grid_t) :: this + integer, intent(in) :: field_lens(:) + integer, intent(in) :: file_lens(:) + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + character(len=*), optional, intent(in) :: field_dnames(:) + character(len=*), optional, intent(in) :: file_dnames(:) + + ! Local variables + integer, pointer :: src_in(:) + integer, pointer :: dest_in(:) + integer, allocatable :: permutation(:) + logical :: is_perm + character(len=128) :: errormsg + + nullify(src_in) + nullify(dest_in) + is_perm = .false. + if (.not. associated(this%map)) then + write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' + call endrun('cam_grid_get_pio_decomp: '//trim(errormsg)) else - ! This is a local variable, pio_put_var should work fine - ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, attr%values) - end if - call cam_pio_handle_error(ierr, 'Error writing variable values in write_cam_grid_val_1d_r8') - deallocate(attr%vardesc(file_index_loc)%p) - nullify(attr%vardesc(file_index_loc)%p) - end if - - end subroutine write_cam_grid_val_1d_r8 - - subroutine cam_grid_write_var(File, grid_id, file_index) - use pio, only: file_desc_t, pio_bcast_error, pio_seterrorhandling - - ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file Handle - integer, intent(in) :: grid_id - integer, optional, intent(in) :: file_index - - ! Local variables - integer :: gridind - integer :: err_handling - class(cam_grid_attribute_t), pointer :: attr - type(cam_grid_attr_ptr_t), pointer :: attrPtr - integer :: file_index_loc - - if (present(file_index)) then - file_index_loc = file_index - else - file_index_loc = 1 - end if - gridind = get_cam_grid_index(grid_id) - ! Only write if not already done - if (cam_grids(gridind)%attrs_defined(file_index_loc)) then - ! Write the horizontal coorinate values - call cam_grids(gridind)%lon_coord%write_var(File, file_index) - call cam_grids(gridind)%lat_coord%write_var(File, file_index) + if (present(field_dnames)) then + call this%find_src_dims(field_dnames, src_in) + end if + if (present(file_dnames)) then + call this%find_dest_dims(file_dnames, dest_in) + end if + if (present(file_dnames) .and. present(field_dnames)) then + ! This only works if the arrays are the same size + if (size(file_dnames) == size(field_dnames)) then + allocate(permutation(size(file_dnames))) + call calc_permutation(file_dnames, field_dnames, & + permutation, is_perm) + end if + end if + ! Call cam_pio_get_decomp with the appropriate options + if (present(field_dnames) .and. present(file_dnames)) then + if (is_perm) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, & + dtype, this%map, field_dist_in=src_in, & + file_dist_in=dest_in, permute=permutation) + else + call cam_pio_get_decomp(iodesc, field_lens, file_lens, & + dtype, this%map, field_dist_in=src_in, & + file_dist_in=dest_in) + end if + else if (present(field_dnames)) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, field_dist_in=src_in) + else if (present(file_dnames)) then + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map, file_dist_in=dest_in) + else + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%map) + end if + end if + if (associated(src_in)) then + deallocate(src_in) + nullify(src_in) + end if + if (associated(dest_in)) then + deallocate(dest_in) + nullify(dest_in) + end if + if (allocated(permutation)) then + deallocate(permutation) + end if + + end subroutine cam_grid_get_pio_decomp + + !------------------------------------------------------------------------ + ! + ! cam_grid_find_dimids: Find the dimension NetCDF IDs on for + ! this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_find_dimids(this, File, dimids) + use pio, only: file_desc_t, pio_noerr, pio_inq_dimid + use pio, only: pio_seterrorhandling, pio_bcast_error + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(out) :: dimids(:) + + ! Local vaariables + integer :: ierr + integer :: err_handling + character(len=max_hcoordname_len) :: dimname1, dimname2 + character(len=*), parameter :: subname = 'CAM_GRID_FIND_DIMIDS' ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) + call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling) - ! Write out the variable values for each grid attribute - attrPtr => cam_grids(gridind)%attributes - do while (associated(attrPtr)) -!!XXgoldyXX: Is this not working in PGI? -! attr => attrPtr%getAttr() - attr => attrPtr%attr - call attr%write_val(File, file_index=file_index_loc) -!!XXgoldyXX: Is this not working in PGI? -! attrPtr => attrPtr%getNext() - attrPtr => attrPtr%next - end do + call this%dim_names(dimname1, dimname2) + if (size(dimids) < 1) then + call endrun(subname//': dimids must have positive size') + end if + dimids = -1 + ! Check the first dimension + ierr = pio_inq_dimid(File, trim(dimname1), dimids(1)) + if(ierr /= PIO_NOERR) then + call endrun(subname//': '//trim(this%name)//' dimension, '//trim(dimname1)//', does not exist on file') + end if + if (trim(dimname1) /= trim(dimname2)) then + ! Structured grid, find second dimid + if (size(dimids) < 2) then + call endrun(subname//': dimids too small for '//trim(this%name)) + end if + ierr = pio_inq_dimid(File, trim(dimname2), dimids(2)) + if(ierr /= PIO_NOERR) then + call endrun(subname//': '//trim(this%name)//' dimension, '//trim(dimname2)//', does not exist on file') + end if + end if - ! Back to previous I/O error handling + ! Back to whatever error handling was running before this routine call pio_seterrorhandling(File, err_handling) - cam_grids(gridind)%attrs_defined(file_index_loc) = .false. - end if - - end subroutine cam_grid_write_var - - logical function cam_grid_block_indexed(this) - class(cam_grid_t) :: this - - cam_grid_block_indexed = this%block_indexed - end function cam_grid_block_indexed - - logical function cam_grid_zonal_grid(this) - class(cam_grid_t) :: this - - cam_grid_zonal_grid = this%zonal_grid - end function cam_grid_zonal_grid - - logical function cam_grid_unstructured(this) - class(cam_grid_t) :: this - - cam_grid_unstructured = this%unstructured - end function cam_grid_unstructured - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_dims: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_dims(this, dims) - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(inout) :: dims(2) - - if (this%is_unstructured()) then - call this%lon_coord%get_coord_len(dims(1)) - dims(2) = 1 - else - call this%lon_coord%get_coord_len(dims(1)) - call this%lat_coord%get_coord_len(dims(2)) - end if - - end subroutine cam_grid_get_dims - - !--------------------------------------------------------------------------- - ! - ! cam_grid_coord_names: Return the names of the grid axes - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_coord_names(this, lon_name, lat_name) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: lat_name - - call this%lon_coord%get_coord_name(lon_name) - call this%lat_coord%get_coord_name(lat_name) - - end subroutine cam_grid_coord_names - - !--------------------------------------------------------------------------- - ! - ! cam_grid_dim_names: Return the names of the dimensions of the grid axes. - ! Note that these may be the same - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_dim_names(this, name1, name2) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(out) :: name1 - character(len=*), intent(out) :: name2 - - call this%lon_coord%get_dim_name(name1) - call this%lat_coord%get_dim_name(name2) - - end subroutine cam_grid_dim_names - - !--------------------------------------------------------------------------- - ! - ! cam_grid_dimensions_id: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_dimensions_id(gridid, dims, rank) - ! Dummy arguments - integer, intent(in) :: gridid - integer, intent(inout) :: dims(2) - integer, optional, intent(out) :: rank - - ! Local variables - integer :: index - character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg - - index = get_cam_grid_index(gridid) - if (index < 0) then - write(errormsg, *) 'No CAM grid with ID =', gridid - call endrun(errormsg) - else - call cam_grids(index)%coord_lengths(dims) - end if - if (present(rank)) then - call cam_grids(index)%dim_names(dname1, dname2) - if (trim(dname1) == trim(dname2)) then - rank = 1 - else - rank = 2 - end if - end if - - end subroutine cam_grid_dimensions_id - - !--------------------------------------------------------------------------- - ! - ! cam_grid_dimensions_name: Return the dimensions of the grid - ! For lon/lat grids, this is (nlon, nlat) - ! For unstructured grids, this is (ncols, 1) - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_dimensions_name(gridname, dims, rank) - ! Dummy arguments - character(len=*), intent(in) :: gridname - integer, intent(inout) :: dims(2) - integer, optional, intent(out) :: rank - - ! Local variables - integer :: gridind - character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg - - gridind = get_cam_grid_index(trim(gridname)) - if (gridind < 0) then - write(errormsg, *) 'No CAM grid with name = ', trim(gridname) - call endrun(errormsg) - else - call cam_grids(gridind)%coord_lengths(dims) - end if - if (present(rank)) then - call cam_grids(gridind)%dim_names(dname1, dname2) - if (trim(dname1) == trim(dname2)) then - rank = 1 - else - rank = 2 - end if - end if - - end subroutine cam_grid_dimensions_name - - !--------------------------------------------------------------------------- - ! - ! cam_grid_set_map: Set a grid's distribution map - ! This maps the local grid elements to global file order - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_set_map(this, map, src, dest) - use mpi, only: mpi_sum, mpi_integer - use spmd_utils, only: mpicom - ! Dummy arguments - class(cam_grid_t) :: this - integer(iMap), pointer :: map(:,:) - integer, intent(in) :: src(2) ! decomp info - integer, intent(in) :: dest(2) ! Standard dim(s) in file - - ! Local variables - integer :: dims(2) - integer :: dstrt, dend - integer :: gridlen, gridloc, ierr - - ! Check to make sure the map meets our needs - call this%coord_lengths(dims) - dend = size(map, 1) - ! We always have to have one source and one destination - if (dest(2) > 0) then - dstrt = dend - 1 - else - dstrt = dend - end if - if ((src(2) /= 0) .and. (dstrt < 3)) then - call endrun('cam_grid_set_map: src & dest too large for map') - else if (dstrt < 2) then - call endrun('cam_grid_set_map: dest too large for map') - ! No else needed - end if - if (dstrt == dend) then - gridloc = count(map(dend,:) /= 0) - else - gridloc = count((map(dstrt,:) /= 0) .and. (map(dend,:) /= 0)) - end if - call MPI_Allreduce(gridloc, gridlen, 1, MPI_INTEGER, MPI_SUM, mpicom, ierr) - if (gridlen /= product(dims)) then - call endrun('cam_grid_set_map: Bad map size for '//trim(this%name)) - else + end subroutine cam_grid_find_dimids + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_2d_int: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_2d_int(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_read_darray_2d_int' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error reading variable') + end subroutine cam_grid_read_darray_2d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_3d_int: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_3d_int(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_read_darray_3d_int' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error reading variable') + end subroutine cam_grid_read_darray_3d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_2d_double: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_2d_double(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: sbnm = 'cam_grid_read_darray_2d_double' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, sbnm//': Error reading variable') + end subroutine cam_grid_read_darray_2d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_3d_double: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: sbnm = 'cam_grid_read_darray_3d_double' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, sbnm//': Error reading variable') + end subroutine cam_grid_read_darray_3d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_2d_real: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_2d_real(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_read_darray_2d_real' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error reading variable') + end subroutine cam_grid_read_darray_2d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_read_darray_3d_real: Read a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_read_darray_3d_real(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t, pio_read_darray + use pio, only: PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(out) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_read_darray_3d_real' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_read_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error reading variable') + end subroutine cam_grid_read_darray_3d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_2d_int: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_INT + + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_2d_int' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + end subroutine cam_grid_write_darray_2d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_3d_int: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_INT + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + integer, intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_3d_int' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + end subroutine cam_grid_write_darray_3d_int + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_1d_double: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_1d_double(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_1d_double' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + end subroutine cam_grid_write_darray_1d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_2d_double: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_2d_double' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + end subroutine cam_grid_write_darray_2d_double + ! + !------------------------------------------------------------------------ + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r8), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_3d_double' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + + end subroutine cam_grid_write_darray_3d_double + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_1d_real: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_1d_real(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_darray_1d_real' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing variable') + end subroutine cam_grid_write_darray_1d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_2d_real: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subnam = 'cam_grid_write_darray_2d_real' + + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subnam//': Error writing variable') + end subroutine cam_grid_write_darray_2d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_write_darray_3d_real: Write a variable defined on this grid + ! + !------------------------------------------------------------------------ + subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, & + hbuf, varid) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_REAL + use cam_pio_utils, only: cam_pio_get_decomp + + ! Dummy arguments + class(cam_grid_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + integer, intent(in) :: adims(:) + integer, intent(in) :: fdims(:) + real(r4), intent(in) :: hbuf(:,:,:) + type(var_desc_t), intent(inout) :: varid + + ! Local variables + type(io_desc_t), pointer :: iodesc + integer :: ierr + character(len=*), parameter :: subnam = 'cam_grid_write_darray_3d_real' + + nullify(iodesc) + call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) + call cam_pio_handle_error(ierr, subnam//': Error writing variable') + end subroutine cam_grid_write_darray_3d_real + + !------------------------------------------------------------------------ + ! + ! cam_grid_get_patch_mask: Compute a map which is defined for locations + ! within the input patch. + ! + !------------------------------------------------------------------------ + subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco) + use spmd_utils, only: mpicom + use mpi, only: mpi_min, mpi_max, mpi_real8 + use shr_const_mod, only: pi=>shr_const_pi + + ! Dummy arguments + class(cam_grid_t) :: this + real(r8), intent(in) :: lonl, lonu ! Longitude bounds + real(r8), intent(in) :: latl, latu ! Latitude bounds + type(cam_grid_patch_t), intent(inout) :: patch + logical, intent(in) :: cco ! Collect columns? + + ! Local arguments + real(r8) :: mindist, minlondist + real(r8) :: dist, temp1, temp2 ! Test distance calc + real(r8) :: londeg, latdeg + real(r8) :: lon, lat + real(r8) :: londeg_min, latdeg_min + real(r8) :: lonmin, lonmax, latmin, latmax + integer :: minind ! Location of closest point + integer :: mapind ! Grid map index + integer :: latind, lonind + integer :: ierr ! For MPI calls + integer :: dims(2) ! Global dim sizes + integer :: gridloc ! local size of grid + logical :: unstructured ! grid type + logical :: findClosest ! .false. == patch output + logical :: isMapped ! .true. iff point in map + + real(r8), parameter :: maxangle = pi / 4.0_r8 + real(r8), parameter :: deg2rad = pi / 180.0_r8 + real(r8), parameter :: maxtol = 0.99999_r8 ! max cos value + real(r8), parameter :: maxlat = pi * maxtol / 2.0_r8 + character(len=*), parameter :: subname = 'cam_grid_get_patch_mask' + if (.not. associated(this%map)) then - allocate(this%map) - end if - call this%map%init(map, this%unstructured, src, dest) - end if - end subroutine cam_grid_set_map - - !--------------------------------------------------------------------------- - ! - ! cam_grid_local_size: return the local size of a 2D array on this grid - ! - !--------------------------------------------------------------------------- - integer function cam_grid_local_size(this) - - ! Dummy argument - class(cam_grid_t) :: this - - ! Local variable - character(len=128) :: errormsg - - if (.not. associated(this%map)) then - write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' - call endrun('cam_grid_local_size: '//trim(errormsg)) - else - cam_grid_local_size = this%map%num_elem() - end if - - end function cam_grid_local_size - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_lon_lat: Find the latitude and longitude for a given - ! grid map index. Note if point is not mapped - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_lon_lat(this, index, lon, lat, isMapped) - - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(in) :: index - real(r8), intent(out) :: lon - real(r8), intent(out) :: lat - logical, intent(out) :: isMapped - - ! Local variables - integer :: latindex, lonindex - character(len=*), parameter :: subname = "cam_grid_get_lon_lat" - - if (this%block_indexed) then - lonindex = index - latindex = index - isMapped = this%map%is_mapped(index) - else - call this%map%coord_vals(index, lonindex, latindex, isMapped) - end if - - !!XXgoldyXX: May be able to relax all the checks - if ( (latindex < LBOUND(this%lat_coord%values, 1)) .or. & - (latindex > UBOUND(this%lat_coord%values, 1))) then - call endrun(trim(subname)//": index out of range for latvals") - else - lat = this%lat_coord%values(latindex) - end if - - if ( (lonindex < LBOUND(this%lon_coord%values, 1)) .or. & - (lonindex > UBOUND(this%lon_coord%values, 1))) then - call endrun(trim(subname)//": index out of range for lonvals") - else - lon = this%lon_coord%values(lonindex) - end if - - end subroutine cam_grid_get_lon_lat - - !--------------------------------------------------------------------------- - ! - ! cam_grid_find_src_dims: Find the correct src array dims for this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_find_src_dims(this, field_dnames, src_out) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(in) :: field_dnames(:) - integer, pointer :: src_out(:) - - ! Local variables - integer :: i, j - integer :: num_coords - character(len=max_hcoordname_len) :: coord_dimnames(2) - - call this%dim_names(coord_dimnames(1), coord_dimnames(2)) - if (associated(src_out)) then - deallocate(src_out) - nullify(src_out) - end if - if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then - num_coords = 1 - else - num_coords = 2 - end if - allocate(src_out(2)) ! Currently, all cases have two source dims - do i = 1, num_coords - do j = 1, size(field_dnames) - if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then - src_out(i) = j - end if - end do - end do - if (num_coords < 2) then - src_out(2) = -1 ! Assume a block structure for unstructured grids - end if - - end subroutine cam_grid_find_src_dims - - !--------------------------------------------------------------------------- - ! - ! cam_grid_find_dest_dims: Find the correct file array dims for this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) - ! Dummy arguments - class(cam_grid_t) :: this - character(len=*), intent(in) :: file_dnames(:) - integer, pointer :: dest_out(:) - - ! Local variables - integer :: i, j - integer :: num_coords - character(len=max_hcoordname_len) :: coord_dimnames(2) - - call this%dim_names(coord_dimnames(1), coord_dimnames(2)) - if (associated(dest_out)) then - deallocate(dest_out) - nullify(dest_out) - end if - if (trim(coord_dimnames(1)) == trim(coord_dimnames(2))) then - num_coords = 1 - else - num_coords = 2 - end if - allocate(dest_out(num_coords)) - dest_out = 0 - do i = 1, num_coords - do j = 1, size(file_dnames) - if (trim(file_dnames(j)) == trim(coord_dimnames(i))) then - dest_out(i) = j - end if - end do - end do - - end subroutine cam_grid_find_dest_dims - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_pio_decomp: Find or create a PIO decomp on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & - iodesc, field_dnames, file_dnames) - use pio, only: io_desc_t - use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation - - ! Dummy arguments - class(cam_grid_t) :: this - integer, intent(in) :: field_lens(:) - integer, intent(in) :: file_lens(:) - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - character(len=*), optional, intent(in) :: field_dnames(:) - character(len=*), optional, intent(in) :: file_dnames(:) - - ! Local variables - integer, pointer :: src_in(:) - integer, pointer :: dest_in(:) - integer, allocatable :: permutation(:) - logical :: is_perm - character(len=128) :: errormsg - - nullify(src_in) - nullify(dest_in) - is_perm = .false. - if (.not. associated(this%map)) then - write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' - call endrun('cam_grid_get_pio_decomp: '//trim(errormsg)) - else - if (present(field_dnames)) then - call this%find_src_dims(field_dnames, src_in) - end if - if (present(file_dnames)) then - call this%find_dest_dims(file_dnames, dest_in) - end if - if (present(file_dnames) .and. present(field_dnames)) then - ! This only works if the arrays are the same size - if (size(file_dnames) == size(field_dnames)) then - allocate(permutation(size(file_dnames))) - call calc_permutation(file_dnames, field_dnames, permutation, is_perm) - end if - end if - ! Call cam_pio_get_decomp with the appropriate options - if (present(field_dnames) .and. present(file_dnames)) then - if (is_perm) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, field_dist_in=src_in, file_dist_in=dest_in, & - permute=permutation) - else - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, field_dist_in=src_in, file_dist_in=dest_in) - end if - else if (present(field_dnames)) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, field_dist_in=src_in) - else if (present(file_dnames)) then - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & - this%map, file_dist_in=dest_in) - else - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%map) + call endrun(subname//': Grid, '//trim(this%name)//', has no map') end if - end if - if (associated(src_in)) then - deallocate(src_in) - nullify(src_in) - end if - if (associated(dest_in)) then - deallocate(dest_in) - nullify(dest_in) - end if - if (allocated(permutation)) then - deallocate(permutation) - end if - - end subroutine cam_grid_get_pio_decomp - - !------------------------------------------------------------------------------- - ! - ! cam_grid_find_dimids: Find the dimension NetCDF IDs on for this grid - ! - !------------------------------------------------------------------------------- - subroutine cam_grid_find_dimids(this, File, dimids) - use pio, only: file_desc_t, pio_noerr, pio_inq_dimid - use pio, only: pio_seterrorhandling, pio_bcast_error - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(out) :: dimids(:) - - ! Local vaariables - integer :: ierr - integer :: err_handling - character(len=max_hcoordname_len) :: dimname1, dimname2 - - ! We will handle errors for this routine - call pio_seterrorhandling(File, PIO_BCAST_ERROR,err_handling) - - call this%dim_names(dimname1, dimname2) - if (size(dimids) < 1) then - call endrun('CAM_GRID_FIND_DIMIDS: dimids must have positive size') - end if - dimids = -1 - ! Check the first dimension - ierr = pio_inq_dimid(File, trim(dimname1), dimids(1)) - if(ierr /= PIO_NOERR) then - call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname1)//', does not exist on file') - end if - if (trim(dimname1) /= trim(dimname2)) then - ! Structured grid, find second dimid - if (size(dimids) < 2) then - call endrun('CAM_GRID_FIND_DIMIDS: dimids too small for '//trim(this%name)) - end if - ierr = pio_inq_dimid(File, trim(dimname2), dimids(2)) - if(ierr /= PIO_NOERR) then - call endrun('CAM_GRID_FIND_DIMIDS: '//trim(this%name)//' dimension, '//trim(dimname2)//', does not exist on file') - end if - end if - - ! Back to whatever error handling was running before this routine - call pio_seterrorhandling(File, err_handling) - - end subroutine cam_grid_find_dimids - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_2d_int: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_2d_int(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_int: Error reading variable') - end subroutine cam_grid_read_darray_2d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_3d_int: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_3d_int(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray, PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_int: Error reading variable') - end subroutine cam_grid_read_darray_3d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_2d_double: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_2d_double(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_double: Error reading variable') - end subroutine cam_grid_read_darray_2d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_3d_double: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_3d_double: Error reading variable') - end subroutine cam_grid_read_darray_3d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_2d_real: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_2d_real(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_real: Error reading variable') - end subroutine cam_grid_read_darray_2d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_read_darray_3d_real: Read a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_read_darray_3d_real(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t, pio_read_darray - use pio, only: PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(out) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_read_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_read_darray_2d_: Error reading variable') - end subroutine cam_grid_read_darray_3d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_2d_int: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_INT - - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_int: Error writing variable') - end subroutine cam_grid_write_darray_2d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_3d_int: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_INT - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - integer, intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_int: Error writing variable') - end subroutine cam_grid_write_darray_3d_int - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_1d_double: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_1d_double(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_1d_double: Error writing variable') - end subroutine cam_grid_write_darray_1d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_2d_double: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_double: Error writing variable') - end subroutine cam_grid_write_darray_2d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_3d_double: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r8), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_double: Error writing variable') - - end subroutine cam_grid_write_darray_3d_double - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_2d_real: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_1d_real(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_1d_real: Error writing variable') - end subroutine cam_grid_write_darray_1d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_2d_real: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_real: Error writing variable') - end subroutine cam_grid_write_darray_2d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_write_darray_3d_real: Write a variable defined on this grid - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, hbuf, varid) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_REAL - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - integer, intent(in) :: adims(:) - integer, intent(in) :: fdims(:) - real(r4), intent(in) :: hbuf(:,:,:) - type(var_desc_t), intent(inout) :: varid - - ! Local variables - type(io_desc_t), pointer :: iodesc - integer :: ierr - - nullify(iodesc) - call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_real: Error writing variable') - end subroutine cam_grid_write_darray_3d_real - - !--------------------------------------------------------------------------- - ! - ! cam_grid_get_patch_mask: Compute a map which is defined for locations - ! within the input patch. - ! - !--------------------------------------------------------------------------- - subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco) - use mpi, only: mpi_min, mpi_max, mpi_real8 - use spmd_utils, only: mpicom - use physconst, only: pi - - ! Dummy arguments - class(cam_grid_t) :: this - real(r8), intent(in) :: lonl, lonu ! Longitude bounds - real(r8), intent(in) :: latl, latu ! Latitude bounds - type(cam_grid_patch_t), intent(inout) :: patch - logical, intent(in) :: cco ! Collect columns? - - ! Local arguments - real(r8) :: mindist, minlondist - real(r8) :: dist, temp1, temp2 ! Test distance calc - real(r8) :: londeg, latdeg - real(r8) :: lon, lat - real(r8) :: londeg_min, latdeg_min - real(r8) :: lonmin, lonmax, latmin, latmax - integer :: minind ! Location of closest point - integer :: mapind ! Grid map index - integer :: latind, lonind - integer :: ierr ! For MPI calls - integer :: dims(2) ! Global dim sizes - integer :: gridloc ! local size of grid - logical :: unstructured ! grid type - logical :: findClosest ! .false. == patch output - logical :: isMapped ! .true. iff point in map - - real(r8), parameter :: maxangle = pi / 4.0_r8 - real(r8), parameter :: deg2rad = pi / 180.0_r8 - real(r8), parameter :: maxtol = 0.99999_r8 ! max cos value - real(r8), parameter :: maxlat = pi * maxtol / 2.0_r8 - character(len=*), parameter :: subname = 'cam_grid_get_patch_mask' - - if (.not. associated(this%map)) then - call endrun('cam_grid_get_patch_mask: Grid, '//trim(this%name)//', has no map') - end if - gridloc = this%map%num_elem() - unstructured = this%is_unstructured() - call this%coord_lengths(dims) - if (associated(patch%mask)) then - if (patch%mask%num_elem() /= gridloc) then - ! The mask needs to be the same size as the map - call endrun(subname//': mask is incorrect size') - ! No else, just needed a check - ! In particular, we are not zeroing the mask since multiple calls with - ! the same mask can be used for collected-column output - ! NB: Compacting the mask must be done after all calls (for a - ! particular mask) to this function. - end if - if (patch%collected_columns .neqv. cco) then - call endrun(subname//': collected_column mismatch') - end if - else - if (associated(patch%latmap)) then - call endrun(subname//': unallocated patch has latmap') - end if - if (associated(patch%lonmap)) then - call endrun(subname//': unallocated patch has lonmap') - end if - call patch%set_patch(lonl, lonu, latl, latu, cco, this%id, this%map) - if (patch%mask%num_elem() /= gridloc) then - ! Basic check to make sure the copy worked - call endrun(subname//': grid map is invalid') - end if - call patch%mask%clear() - ! Set up the lat/lon maps - if (cco) then - ! For collected column output, we need to collect coordinates and values - allocate(patch%latmap(patch%mask%num_elem())) - patch%latmap = 0 - allocate(patch%latvals(patch%mask%num_elem())) - patch%latvals = 91.0_r8 - allocate(patch%lonmap(patch%mask%num_elem())) - patch%lonmap = 0 - allocate(patch%lonvals(patch%mask%num_elem())) - patch%lonvals = 361.0_r8 - else - if (associated(this%lat_coord%values)) then - allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1))) - patch%latmap = 0 - else - nullify(patch%latmap) - end if - if (associated(this%lon_coord%values)) then - allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1))) - patch%lonmap = 0 - else - nullify(patch%lonmap) - end if - end if - end if - - ! We have to iterate through each grid point to check - ! We have four cases, structured vs. unstructured grid * - ! patch area vs. closest column - ! Note that a 1-d patch 'area' is not allowed for unstructured grids - findClosest = .false. - ! Make sure our search items are in order - lonmin = min(lonl, lonu) - lonmax = max(lonl, lonu) - latmin = min(latl, latu) - latmax = max(latl, latu) - if (lonl == lonu) then - if (latl == latu) then - findClosest = .true. - else if (unstructured) then - call endrun(subname//': 1-D patch (lon) not allowed for unstructured grids') + gridloc = this%map%num_elem() + unstructured = this%is_unstructured() + call this%coord_lengths(dims) + if (associated(patch%mask)) then + if (patch%mask%num_elem() /= gridloc) then + ! The mask needs to be the same size as the map + call endrun(subname//': mask is incorrect size') + ! No else, just needed a check + ! In particular, we are not zeroing the mask since multiple + ! calls the same mask can be used for collected-column output + ! NB: Compacting the mask must be done after all calls (for a + ! particular mask) to this function. + end if + if (patch%collected_columns .neqv. cco) then + call endrun(subname//': collected_column mismatch') + end if else - ! Find closest lon line to lonu - ! This is a lat lon grid so it should have coordinate axes - lonmin = 365.0_r8 - mindist = 365.0_r8 - if (associated(this%lon_coord%values)) then - do lonind = LBOUND(this%lon_coord%values, 1), UBOUND(this%lon_coord%values, 1) - dist = abs(this%lon_coord%values(lonind) - lonu) - if (dist < mindist) then - lonmin = this%lon_coord%values(lonind) - mindist = dist - end if - end do - end if - ! Get the global minimum - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) - if (dist == mindist) then - ! We have a ringer so use only that longitude - lonmax = lonmin - else - ! We don't have a minimum dist so count no points - lonmax = lonmin - 1.0_r8 - end if - end if - else if (latl == latu) then - if (unstructured) then - call endrun(subname//': 1-D patch (lat) not allowed for unstructured grids') - else - ! Find closest lat line to latu - ! This is a lat lon grid so it should have coordinate axes - latmin = 91.0_r8 - mindist = 181.0_r8 - if (associated(this%lat_coord%values)) then - do latind = LBOUND(this%lat_coord%values, 1), UBOUND(this%lat_coord%values, 1) - dist = abs(this%lat_coord%values(latind) - latl) - if (dist < mindist) then - latmin = this%lat_coord%values(latind) - mindist = dist - end if - end do - end if - ! Get the global minimum - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) - if (dist == mindist) then - ! We have a ringer so use only that latitude - latmax = latmin - else - ! We don't have a minimum dist so count no points - latmax = latmin - 1.0_r8 - end if - end if - end if - - ! Convert to radians - lonmin = lonmin * deg2rad - lonmax = lonmax * deg2rad - latmin = latmin * deg2rad - latmax = latmax * deg2rad - ! Loop through all the local grid elements and find the closest match - ! (or all matches depending on the value of findClosest) - minind = -1 - londeg_min = 361.0_r8 - latdeg_min = 91.0_r8 - mindist = 2.0_r8 * pi - - do mapind = 1, patch%mask%num_elem() - call this%get_lon_lat(mapind, londeg, latdeg, isMapped) - if (isMapped) then - lon = londeg * deg2rad - lat = latdeg * deg2rad - if (findClosest) then - ! Use the Spherical Law of Cosines to find the great-circle distance. - ! Might as well use the unit sphere since we just want differences - if ( (abs(lat - latmin) <= maxangle) .and. & - (abs(lon - lonmin) <= maxangle)) then - ! maxangle could be pi but why waste all those trig functions? - ! XXgoldyXX: What should we use for maxangle given coarse Eul grids? - if ((lat == latmin) .and. (lon == lonmin)) then - dist = 0.0_r8 + if (associated(patch%latmap)) then + call endrun(subname//': unallocated patch has latmap') + end if + if (associated(patch%lonmap)) then + call endrun(subname//': unallocated patch has lonmap') + end if + call patch%set_patch(lonl, lonu, latl, latu, cco, this%id, this%map) + if (patch%mask%num_elem() /= gridloc) then + ! Basic check to make sure the copy worked + call endrun(subname//': grid map is invalid') + end if + call patch%mask%clear() + ! Set up the lat/lon maps + if (cco) then + ! For collected column output, we need to collect + ! coordinates and values + allocate(patch%latmap(patch%mask%num_elem())) + patch%latmap = 0 + allocate(patch%latvals(patch%mask%num_elem())) + patch%latvals = 91.0_r8 + allocate(patch%lonmap(patch%mask%num_elem())) + patch%lonmap = 0 + allocate(patch%lonvals(patch%mask%num_elem())) + patch%lonvals = 361.0_r8 + else + if (associated(this%lat_coord%values)) then + allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1))) + patch%latmap = 0 else - temp1 = (sin(latmin) * sin(lat)) + & - (cos(latmin) * cos(lat) * cos(lon - lonmin)) - if (temp1 > maxtol) then - ! Use haversine formula - temp1 = sin(latmin - lat) - temp2 = sin((lonmin - lon) / 2.0_r8) - dist = 2.0_r8 * asin((temp1*temp1) + (cos(latmin)*cos(lat)*temp2*temp2)) - else - dist = acos(temp1) - end if + nullify(patch%latmap) end if - if ( (dist < mindist) .or. & - ((dist == mindist) .and. & - (abs(lon - lonmin) < abs(londeg_min*deg2rad - lonmin)))) then - minind = mapind - mindist = dist - londeg_min = londeg - latdeg_min = latdeg + if (associated(this%lon_coord%values)) then + allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1))) + patch%lonmap = 0 + else + nullify(patch%lonmap) end if - end if - else - if ( (latmin <= lat) .and. (lat <= latmax) .and. & - (lonmin <= lon) .and. (lon <= lonmax)) then - if (patch%mask%num_elem() >= mapind) then - if (.not. patch%mask%is_mapped(mapind)) then - call patch%mask%copy_elem(this%map, mapind) - patch%num_points = patch%num_points + 1 - if (cco) then - if (patch%num_points > size(patch%latvals, 1)) then - call endrun(subname//': Number of cols larger than mask!?') - end if - call this%map%coord_dests(mapind, lonind, latind) - if (latind > 0) then - ! Grid is structured, get unique index - lonind = lonind + (latind * dims(1)) - end if - patch%latmap(patch%num_points) = lonind - patch%latvals(patch%num_points) = latdeg - patch%lonmap(patch%num_points) = lonind - patch%lonvals(patch%num_points) = londeg - else if ((this%block_indexed) .or. unstructured) then - call this%map%coord_dests(mapind, lonind, latind) - if (latind == 0) then - latind = lonind + end if + end if + + ! We have to iterate through each grid point to check + ! We have four cases, structured vs. unstructured grid * + ! patch area vs. closest column + ! Note that a 1-d patch 'area' is not allowed for unstructured grids + findClosest = .false. + ! Make sure our search items are in order + lonmin = min(lonl, lonu) + lonmax = max(lonl, lonu) + latmin = min(latl, latu) + latmax = max(latl, latu) + if (lonl == lonu) then + if (latl == latu) then + findClosest = .true. + else if (unstructured) then + call endrun(subname//': 1-D patch (lon) not allowed for unstructured grids') + else + ! Find closest lon line to lonu + ! This is a lat lon grid so it should have coordinate axes + lonmin = 365.0_r8 + mindist = 365.0_r8 + if (associated(this%lon_coord%values)) then + do lonind = LBOUND(this%lon_coord%values, 1), UBOUND(this%lon_coord%values, 1) + dist = abs(this%lon_coord%values(lonind) - lonu) + if (dist < mindist) then + lonmin = this%lon_coord%values(lonind) + mindist = dist end if - if (associated(patch%latmap)) then - patch%latmap(mapind) = latind + end do + end if + ! Get the global minimum + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) + if (dist == mindist) then + ! We have a ringer so use only that longitude + lonmax = lonmin + else + ! We don't have a minimum dist so count no points + lonmax = lonmin - 1.0_r8 + end if + end if + else if (latl == latu) then + if (unstructured) then + call endrun(subname//': 1-D patch (lat) not allowed for unstructured grids') + else + ! Find closest lat line to latu + ! This is a lat lon grid so it should have coordinate axes + latmin = 91.0_r8 + mindist = 181.0_r8 + if (associated(this%lat_coord%values)) then + do latind = LBOUND(this%lat_coord%values, 1), & + UBOUND(this%lat_coord%values, 1) + dist = abs(this%lat_coord%values(latind) - latl) + if (dist < mindist) then + latmin = this%lat_coord%values(latind) + mindist = dist end if - if (associated(patch%lonmap)) then - patch%lonmap(mapind) = lonind + end do + end if + ! Get the global minimum + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, & + mpicom, ierr) + if (dist == mindist) then + ! We have a ringer so use only that latitude + latmax = latmin + else + ! We don't have a minimum dist so count no points + latmax = latmin - 1.0_r8 + end if + end if + end if + + ! Convert to radians + lonmin = lonmin * deg2rad + lonmax = lonmax * deg2rad + latmin = latmin * deg2rad + latmax = latmax * deg2rad + ! Loop through all the local grid elements and find the closest match + ! (or all matches depending on the value of findClosest) + minind = -1 + londeg_min = 361.0_r8 + latdeg_min = 91.0_r8 + mindist = 2.0_r8 * pi + + do mapind = 1, patch%mask%num_elem() + call this%get_lon_lat(mapind, londeg, latdeg, isMapped) + if (isMapped) then + lon = londeg * deg2rad + lat = latdeg * deg2rad + if (findClosest) then + ! Use the Spherical Law of Cosines to find the great-circle distance. + ! Might as well use the unit sphere since we just want differences + if ( (abs(lat - latmin) <= maxangle) .and. & + (abs(lon - lonmin) <= maxangle)) then + ! maxangle could be pi but why waste all those trig functions? + ! XXgoldyXX: What should we use for maxangle given coarse Eul grids? + if ((lat == latmin) .and. (lon == lonmin)) then + dist = 0.0_r8 + else + temp1 = (sin(latmin) * sin(lat)) + & + (cos(latmin) * cos(lat) * cos(lon - lonmin)) + if (temp1 > maxtol) then + ! Use haversine formula + temp1 = sin(latmin - lat) + temp2 = sin((lonmin - lon) / 2.0_r8) + dist = 2.0_r8 * asin((temp1*temp1) + & + (cos(latmin)*cos(lat)*temp2*temp2)) + else + dist = acos(temp1) + end if end if - else - call this%map%coord_vals(mapind, lonind, latind) - if (associated(patch%latmap)) then - patch%latmap(latind) = latind + if ( (dist < mindist) .or. & + ((dist == mindist) .and. & + (abs(lon - lonmin) < abs(londeg_min*deg2rad - lonmin)))) then + minind = mapind + mindist = dist + londeg_min = londeg + latdeg_min = latdeg end if - if (associated(patch%lonmap)) then - patch%lonmap(lonind) = lonind + end if + else + if ( (latmin <= lat) .and. (lat <= latmax) .and. & + (lonmin <= lon) .and. (lon <= lonmax)) then + if (patch%mask%num_elem() >= mapind) then + if (.not. patch%mask%is_mapped(mapind)) then + call patch%mask%copy_elem(this%map, mapind) + patch%num_points = patch%num_points + 1 + if (cco) then + if (patch%num_points > size(patch%latvals, 1)) then + call endrun(subname//': Number of cols larger than mask!?') + end if + call this%map%coord_dests(mapind, lonind, latind) + if (latind > 0) then + ! Grid is structured, get unique index + lonind = lonind + (latind * dims(1)) + end if + patch%latmap(patch%num_points) = lonind + patch%latvals(patch%num_points) = latdeg + patch%lonmap(patch%num_points) = lonind + patch%lonvals(patch%num_points) = londeg + else if ((this%block_indexed) .or. unstructured) then + call this%map%coord_dests(mapind, lonind, latind) + if (latind == 0) then + latind = lonind + end if + if (associated(patch%latmap)) then + patch%latmap(mapind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(mapind) = lonind + end if + else + call this%map%coord_vals(mapind, lonind, latind) + if (associated(patch%latmap)) then + patch%latmap(latind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(lonind) = lonind + end if + end if + ! else do nothing, we already found this point + end if + else + call endrun(subname//': PE has patch points but mask too small') end if - end if - ! else do nothing, we already found this point - end if + end if + end if ! findClosest + end if ! isMapped + end do + if (findClosest) then + ! We need to find the minimum mindist and use only that value + dist = mindist + call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) + ! Special case for pole points + if (latdeg_min > 90.0_r8) then + temp1 = 0.0_r8 + else + temp1 = abs(latdeg_min*deg2rad) + end if + call MPI_allreduce(temp1, lat, 1, mpi_real8, mpi_max, mpicom, ierr) + if ((abs(latmin) > maxlat) .or. (lat > maxlat)) then + if (dist == mindist) then + ! Only distance winners can compete + lon = abs(londeg_min - lonl) else - call endrun(subname//': PE has patch points but mask too small') + lon = 361.0_r8 end if - end if - end if ! findClosest - end if ! isMapped - end do - if (findClosest) then - ! We need to find the minimum mindist and use only that value - dist = mindist - call MPI_allreduce(dist, mindist, 1, mpi_real8, mpi_min, mpicom, ierr) - ! Special case for pole points - if (latdeg_min > 90.0_r8) then - temp1 = 0.0_r8 - else - temp1 = abs(latdeg_min*deg2rad) - end if - call MPI_allreduce(temp1, lat, 1, mpi_real8, mpi_max, mpicom, ierr) - if ((abs(latmin) > maxlat) .or. (lat > maxlat)) then - if (dist == mindist) then - ! Only distance winners can compete - lon = abs(londeg_min - lonl) - else - lon = 361.0_r8 - end if - call MPI_allreduce(lon, minlondist, 1, mpi_real8, mpi_min, mpicom, ierr) - ! Kill the losers - if (lon /= minlondist) then - dist = dist + 1.0_r8 - end if - end if - ! Now, only task(s) which have real minimum distance should set their mask - ! minind test allows for no match - if (dist == mindist) then - if (minind < 0) then - call endrun("cam_grid_get_patch_mask: No closest point found!!") - else - if (patch%mask%num_elem() >= minind) then - if (.not. patch%mask%is_mapped(minind)) then - call patch%mask%copy_elem(this%map, minind) - patch%num_points = patch%num_points + 1 - if (cco) then - if (patch%num_points > size(patch%latvals, 1)) then - call endrun(subname//': Number of columns larger than mask!?') - end if - call this%map%coord_dests(minind, lonind, latind) - if (latind > 0) then - ! Grid is structured, get unique index - lonind = lonind + (latind * dims(1)) - end if - patch%latmap(patch%num_points) = lonind - patch%latvals(patch%num_points) = latdeg_min - patch%lonmap(patch%num_points) = lonind - patch%lonvals(patch%num_points) = londeg_min - else if ((this%block_indexed) .or. unstructured) then - call this%map%coord_dests(minind, lonind, latind) - if (latind == 0) then - latind = lonind - end if - if (associated(patch%latmap)) then - patch%latmap(minind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(minind) = lonind - end if - else - call this%map%coord_vals(minind, lonind, latind) - if (associated(patch%latmap)) then - patch%latmap(latind) = latind - end if - if (associated(patch%lonmap)) then - patch%lonmap(lonind) = lonind - end if - end if - ! else do nothing, we already found this point + call MPI_allreduce(lon, minlondist, 1, mpi_real8, mpi_min, mpicom, ierr) + ! Kill the losers + if (lon /= minlondist) then + dist = dist + 1.0_r8 end if - else - call endrun(subname//': PE has patch closest point but mask too small') - end if - end if - end if - end if ! findClosest + end if + ! Now, only task(s) which have real minimum distance should set their mask + ! minind test allows for no match + if (dist == mindist) then + if (minind < 0) then + call endrun("cam_grid_get_patch_mask: No closest point found!!") + else + if (patch%mask%num_elem() >= minind) then + if (.not. patch%mask%is_mapped(minind)) then + call patch%mask%copy_elem(this%map, minind) + patch%num_points = patch%num_points + 1 + if (cco) then + if (patch%num_points > size(patch%latvals, 1)) then + call endrun(subname//': Number of columns larger than mask!?') + end if + call this%map%coord_dests(minind, lonind, latind) + if (latind > 0) then + ! Grid is structured, get unique index + lonind = lonind + (latind * dims(1)) + end if + patch%latmap(patch%num_points) = lonind + patch%latvals(patch%num_points) = latdeg_min + patch%lonmap(patch%num_points) = lonind + patch%lonvals(patch%num_points) = londeg_min + else if ((this%block_indexed) .or. unstructured) then + call this%map%coord_dests(minind, lonind, latind) + if (latind == 0) then + latind = lonind + end if + if (associated(patch%latmap)) then + patch%latmap(minind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(minind) = lonind + end if + else + call this%map%coord_vals(minind, lonind, latind) + if (associated(patch%latmap)) then + patch%latmap(latind) = latind + end if + if (associated(patch%lonmap)) then + patch%lonmap(lonind) = lonind + end if + end if + ! else do nothing, we already found this point + end if + else + call endrun(subname//': PE has patch closest point but mask too small') + end if + end if + end if + end if ! findClosest + + end subroutine cam_grid_get_patch_mask - end subroutine cam_grid_get_patch_mask + !------------------------------------------------------------------------ + ! + ! Grid Patch functions + ! + !------------------------------------------------------------------------ - !--------------------------------------------------------------------------- - ! - ! Grid Patch functions - ! - !--------------------------------------------------------------------------- + integer function cam_grid_patch_get_id(this) result(id) - integer function cam_grid_patch_get_id(this) result(id) + ! Dummy argument + class(cam_grid_patch_t) :: this + + id = this%grid_id + end function cam_grid_patch_get_id + + subroutine cam_grid_patch_get_global_size_map(this, gsize) + + ! Dummy arguments + class(cam_grid_patch_t), intent(in) :: this + integer, intent(out) :: gsize - ! Dummy argument - class(cam_grid_patch_t) :: this + gsize = this%global_size - id = this%grid_id - end function cam_grid_patch_get_id + end subroutine cam_grid_patch_get_global_size_map - subroutine cam_grid_patch_get_global_size_map(this, gsize) + subroutine cam_grid_patch_get_global_size_axes(this, latsize, lonsize) - ! Dummy arguments - class(cam_grid_patch_t), intent(in) :: this - integer, intent(out) :: gsize + ! Dummy arguments + class(cam_grid_patch_t), intent(in) :: this + integer, intent(out) :: latsize + integer, intent(out) :: lonsize - gsize = this%global_size + latsize = this%global_lat_size + lonsize = this%global_lon_size - end subroutine cam_grid_patch_get_global_size_map + end subroutine cam_grid_patch_get_global_size_axes - subroutine cam_grid_patch_get_global_size_axes(this, latsize, lonsize) + ! cam_grid_patch_get_axis_names + ! Collect or compute unique names for the latitude and longitude axes + ! If the grid is unstructured or col_output is .true., the column + ! dimension name is also generated (e.g., ncol) + subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, & + col_name, col_output) - ! Dummy arguments - class(cam_grid_patch_t), intent(in) :: this - integer, intent(out) :: latsize - integer, intent(out) :: lonsize + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(out) :: lat_name + character(len=*), intent(out) :: lon_name + character(len=*), intent(out) :: col_name + logical, intent(in) :: col_output + + ! Local variable + integer :: index + character(len=120) :: errormsg + character(len=max_hcoordname_len) :: grid_name + logical :: unstruct + + if (cam_grid_check(this%grid_id)) then + index = this%grid_index() + unstruct = cam_grids(index)%is_unstructured() + ! Get coordinate and dim names + call cam_grids(index)%lat_coord%get_coord_name(lat_name) + call cam_grids(index)%lon_coord%get_coord_name(lon_name) + grid_name = cam_grids(index)%name + if (col_output .or. unstruct) then + ! In this case, we are using collect_column_output on a lat/lon grid + col_name = 'ncol_'//trim(grid_name) + lat_name = trim(lat_name)//'_'//trim(grid_name) + lon_name = trim(lon_name)//'_'//trim(grid_name) + else + ! Separate patch output for a lat/lon grid + col_name = '' + lat_name = trim(lat_name)//'_'//trim(grid_name) + lon_name = trim(lon_name)//'_'//trim(grid_name) + end if + else + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_axis_names: '//errormsg) + end if - latsize = this%global_lat_size - lonsize = this%global_lon_size + end subroutine cam_grid_patch_get_axis_names - end subroutine cam_grid_patch_get_global_size_axes + subroutine cam_grid_patch_get_coord_long_name(this, axis, name) - ! cam_grid_patch_get_axis_names - ! Collect or compute unique names for the latitude and longitude axes - ! If the grid is unstructured or col_output is .true., the column - ! dimension name is also generated (e.g., ncol) - subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, & - col_name, col_output) + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(in) :: axis + character(len=*), intent(out) :: name + + ! Local variable + character(len=120) :: errormsg + integer :: index + + if (cam_grid_check(this%grid_id)) then + index = this%grid_index() + if (trim(axis) == 'lat') then + call cam_grids(index)%lat_coord%get_long_name(name) + else if (trim(axis) == 'lon') then + call cam_grids(index)%lon_coord%get_long_name(name) + else + write(errormsg, *) 'Bad axis name:', axis + call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) + end if + else + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) + end if - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(out) :: lat_name - character(len=*), intent(out) :: lon_name - character(len=*), intent(out) :: col_name - logical, intent(in) :: col_output + end subroutine cam_grid_patch_get_coord_long_name - ! Local variable - integer :: index - character(len=120) :: errormsg - character(len=max_hcoordname_len) :: grid_name - logical :: unstruct + subroutine cam_grid_patch_get_coord_units(this, axis, units) - if (cam_grid_check(this%grid_id)) then - index = this%grid_index() - unstruct = cam_grids(index)%is_unstructured() - ! Get coordinate and dim names - call cam_grids(index)%lat_coord%get_coord_name(lat_name) - call cam_grids(index)%lon_coord%get_coord_name(lon_name) - grid_name = cam_grids(index)%name - if (col_output .or. unstruct) then - ! In this case, we are using collect_column_output on a lat/lon grid - col_name = 'ncol_'//trim(grid_name) - lat_name = trim(lat_name)//'_'//trim(grid_name) - lon_name = trim(lon_name)//'_'//trim(grid_name) + ! Dummy arguments + class(cam_grid_patch_t) :: this + character(len=*), intent(in) :: axis + character(len=*), intent(out) :: units + + ! Local variable + character(len=120) :: errormsg + integer :: index + + if (cam_grid_check(this%grid_id)) then + index = this%grid_index() + if (trim(axis) == 'lat') then + call cam_grids(index)%lat_coord%get_units(units) + else if (trim(axis) == 'lon') then + call cam_grids(index)%lon_coord%get_units(units) + else + write(errormsg, *) 'Bad axis name:', axis + call endrun('cam_grid_patch_get_coord_units: '//errormsg) + end if else - ! Separate patch output for a lat/lon grid - col_name = '' - lat_name = trim(lat_name)//'_'//trim(grid_name) - lon_name = trim(lon_name)//'_'//trim(grid_name) + write(errormsg, *) 'Bad grid ID:', this%grid_id + call endrun('cam_grid_patch_get_coord_units: '//errormsg) + end if + + end subroutine cam_grid_patch_get_coord_units + + subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, & + id, map) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + real(r8), intent(in) :: lonl, lonu ! Longitude bounds + real(r8), intent(in) :: latl, latu ! Latitude bounds + logical, intent(in) :: cco ! Collect columns? + integer, intent(in) :: id + type(cam_filemap_t), intent(in) :: map + + this%grid_id = id + this%lon_range(1) = lonl + this%lon_range(2) = lonu + this%lat_range(1) = latl + this%lat_range(2) = latu + this%collected_columns = cco + if (.not. associated(this%mask)) then + allocate(this%mask) end if - else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_axis_names: '//errormsg) - end if + call this%mask%copy(map) + call this%mask%new_index() + + end subroutine cam_grid_patch_set_patch + + subroutine cam_grid_patch_get_decomp(this, field_lens, file_lens, & + dtype, iodesc, file_dest_in) + use pio, only: io_desc_t + use cam_pio_utils, only: cam_pio_get_decomp - end subroutine cam_grid_patch_get_axis_names + ! Dummy arguments + class(cam_grid_patch_t) :: this + integer, intent(in) :: field_lens(:) + integer, intent(in) :: file_lens(:) + integer, intent(in) :: dtype + type(io_desc_t), pointer, intent(out) :: iodesc + integer, optional, intent(in) :: file_dest_in(:) + + call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, & + this%mask, file_dist_in=file_dest_in) - subroutine cam_grid_patch_get_coord_long_name(this, axis, name) + end subroutine cam_grid_patch_get_decomp - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(in) :: axis - character(len=*), intent(out) :: name + subroutine cam_grid_patch_compact(this, collected_output) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + logical, optional, intent(in) :: collected_output - ! Local variable - character(len=120) :: errormsg - integer :: index + ! Local variables + integer :: index ! Our grid's index + logical :: dups_ok - if (cam_grid_check(this%grid_id)) then index = this%grid_index() - if (trim(axis) == 'lat') then - call cam_grids(index)%lat_coord%get_long_name(name) - else if (trim(axis) == 'lon') then - call cam_grids(index)%lon_coord%get_long_name(name) + if (index > 0) then + dups_ok = cam_grids(index)%is_unstructured() else - write(errormsg, *) 'Bad axis name:', axis - call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) + ! This is probably an error condition but someone else will + ! catch it first + dups_ok = .false. end if - else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_coord_long_name: '//errormsg) - end if + if (present(collected_output)) then + dups_ok = dups_ok .or. collected_output + end if + call this%mask%compact(this%lonmap, this%latmap, & + num_lons=this%global_lon_size, num_lats=this%global_lat_size, & + num_mapped=this%global_size, columnize=collected_output, & + dups_ok_in=dups_ok) + + end subroutine cam_grid_patch_compact - end subroutine cam_grid_patch_get_coord_long_name + subroutine cam_grid_patch_get_active_cols(this, lchnk, active, srcdim_in) + + ! Dummy arguments + class(cam_grid_patch_t) :: this + integer, intent(in) :: lchnk + logical, intent(out) :: active(:) + integer, optional, intent(in) :: srcdim_in - subroutine cam_grid_patch_get_coord_units(this, axis, units) + if (.not. associated(this%mask)) then + call endrun('cam_grid_patch_get_active_cols: No mask') + else + call this%mask%active_cols(lchnk, active, srcdim_in) + end if - ! Dummy arguments - class(cam_grid_patch_t) :: this - character(len=*), intent(in) :: axis - character(len=*), intent(out) :: units + end subroutine cam_grid_patch_get_active_cols - ! Local variable - character(len=120) :: errormsg - integer :: index + ! cam_grid_patch_write_vals: Write lat and lon coord values to File + subroutine cam_grid_patch_write_vals(this, File, header_info) + use pio, only: file_desc_t, io_desc_t + use pio, only: pio_write_darray, PIO_DOUBLE + use pio, only: pio_freedecomp + use cam_pio_utils, only: cam_pio_handle_error, cam_pio_newdecomp - if (cam_grid_check(this%grid_id)) then - index = this%grid_index() - if (trim(axis) == 'lat') then - call cam_grids(index)%lat_coord%get_units(units) - else if (trim(axis) == 'lon') then - call cam_grids(index)%lon_coord%get_units(units) + ! Dummy arguments + class(cam_grid_patch_t) :: this + type(file_desc_t), intent(inout) :: File ! PIO file handle + type(cam_grid_header_info_t), intent(inout) :: header_info + + ! Local variables + type(io_desc_t), pointer :: iodesc + type(var_desc_t), pointer :: vdesc + real(r8), pointer :: coord_p(:) + real(r8), pointer :: coord(:) + integer(iMap), pointer :: map(:) + integer :: field_lens(1) + integer :: file_lens(1) + integer :: ierr + character(len=*), parameter :: subname = 'CAM_GRID_PATCH_WRITE_VALS' + + nullify(vdesc) + nullify(coord_p) + nullify(coord) + nullify(map) + nullify(iodesc) + if (this%grid_id /= header_info%get_gridid()) then + call endrun(subname//': Grid id mismatch') + end if + ! Write out lon + if (associated(this%lonmap)) then + field_lens(1) = size(this%lonmap, 1) + map => this%lonmap else - write(errormsg, *) 'Bad axis name:', axis - call endrun('cam_grid_patch_get_coord_units: '//errormsg) - end if - else - write(errormsg, *) 'Bad grid ID:', this%grid_id - call endrun('cam_grid_patch_get_coord_units: '//errormsg) - end if - - end subroutine cam_grid_patch_get_coord_units - - subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, id, map) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - real(r8), intent(in) :: lonl, lonu ! Longitude bounds - real(r8), intent(in) :: latl, latu ! Latitude bounds - logical, intent(in) :: cco ! Collect columns? - integer, intent(in) :: id - type(cam_filemap_t), intent(in) :: map - - this%grid_id = id - this%lon_range(1) = lonl - this%lon_range(2) = lonu - this%lat_range(1) = latl - this%lat_range(2) = latu - this%collected_columns = cco - if (.not. associated(this%mask)) then - allocate(this%mask) - end if - call this%mask%copy(map) - call this%mask%new_index() - - end subroutine cam_grid_patch_set_patch - - subroutine cam_grid_patch_get_decomp(this, field_lens, file_lens, dtype, & - iodesc, file_dest_in) - use pio, only: io_desc_t - use cam_pio_utils, only: cam_pio_get_decomp - - ! Dummy arguments - class(cam_grid_patch_t) :: this - integer, intent(in) :: field_lens(:) - integer, intent(in) :: file_lens(:) - integer, intent(in) :: dtype - type(io_desc_t), pointer, intent(out) :: iodesc - integer, optional, intent(in) :: file_dest_in(:) - - call cam_pio_get_decomp(iodesc, field_lens, file_lens, dtype, this%mask, & - file_dist_in=file_dest_in) - - end subroutine cam_grid_patch_get_decomp - - subroutine cam_grid_patch_compact(this, collected_output) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - logical, optional, intent(in) :: collected_output - - ! Local variables - integer :: index ! Our grid's index - logical :: dups_ok - - index = this%grid_index() - if (index > 0) then - dups_ok = cam_grids(index)%is_unstructured() - else - ! This is probably an error condition but someone else will catch it first - dups_ok = .false. - end if - if (present(collected_output)) then - dups_ok = dups_ok .or. collected_output - end if - call this%mask%compact(this%lonmap, this%latmap, & - num_lons=this%global_lon_size, num_lats=this%global_lat_size, & - num_mapped=this%global_size, columnize=collected_output, & - dups_ok_in=dups_ok) - - end subroutine cam_grid_patch_compact - - subroutine cam_grid_patch_get_active_cols(this, lchnk, active, srcdim_in) - - ! Dummy arguments - class(cam_grid_patch_t) :: this - integer, intent(in) :: lchnk - logical, intent(out) :: active(:) - integer, optional, intent(in) :: srcdim_in - - if (.not. associated(this%mask)) then - call endrun('cam_grid_patch_get_active_cols: No mask') - else - call this%mask%active_cols(lchnk, active, srcdim_in) - end if - - end subroutine cam_grid_patch_get_active_cols - - ! cam_grid_patch_write_vals: Write lat and lon coord values to File - subroutine cam_grid_patch_write_vals(this, File, header_info) - use pio, only: file_desc_t, io_desc_t - use pio, only: pio_write_darray, PIO_DOUBLE - use pio, only: pio_initdecomp, pio_freedecomp - use cam_pio_utils, only: cam_pio_handle_error, pio_subsystem - - ! Dummy arguments - class(cam_grid_patch_t) :: this - type(file_desc_t), intent(inout) :: File ! PIO file handle - type(cam_grid_header_info_t), intent(inout) :: header_info - - ! Local variables - type(io_desc_t) :: iodesc - type(var_desc_t), pointer :: vdesc - real(r8), pointer :: coord_p(:) - real(r8), pointer :: coord(:) - integer(iMap), pointer :: map(:) - integer :: field_lens(1) - integer :: file_lens(1) - integer :: ierr - - nullify(vdesc) - nullify(coord_p) - nullify(coord) - nullify(map) - if (this%grid_id /= header_info%get_gridid()) then - call endrun('CAM_GRID_PATCH_WRITE_VALS: Grid id mismatch') - end if - ! Write out lon - if (associated(this%lonmap)) then - field_lens(1) = size(this%lonmap, 1) - map => this%lonmap - else - field_lens(1) = 0 - allocate(map(0)) - end if - file_lens(1) = this%global_lon_size - !! XXgoldyXX: Think about caching these decomps - call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc) - if (associated(this%lonvals)) then - coord => this%lonvals - else - coord_p => cam_grid_get_lonvals(this%grid_id) - if (associated(coord_p)) then - coord => coord_p + field_lens(1) = 0 + allocate(map(0)) + end if + file_lens(1) = this%global_lon_size + !! XXgoldyXX: Think about caching these decomps + call cam_pio_newdecomp(iodesc, file_lens, map, pio_double) + if (associated(this%lonvals)) then + coord => this%lonvals else - allocate(coord(0)) - end if - end if - vdesc => header_info%get_lon_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing longitude') - if (.not. associated(this%lonmap)) then - deallocate(map) - nullify(map) - end if - if (.not. (associated(coord_p) .or. associated(this%lonvals))) then - deallocate(coord) - nullify(coord) - end if - call pio_freedecomp(File, iodesc) - ! Write out lat - if (associated(this%latmap)) then - field_lens(1) = size(this%latmap, 1) - map => this%latmap - else - field_lens(1) = 0 - allocate(map(0)) - end if - file_lens(1) = this%global_lat_size - !! XXgoldyXX: Think about caching these decomps - call pio_initdecomp(pio_subsystem, pio_double, file_lens, map, iodesc) - - if (associated(this%latvals)) then - coord => this%latvals - else - coord_p => cam_grid_get_latvals(this%grid_id) - if (associated(coord_p)) then - coord => coord_p + coord_p => cam_grid_get_lonvals(this%grid_id) + if (associated(coord_p)) then + coord => coord_p + else + allocate(coord(0)) + end if + end if + vdesc => header_info%get_lon_varid() + call pio_write_darray(File, vdesc, iodesc, coord, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing longitude') + if (.not. associated(this%lonmap)) then + deallocate(map) + nullify(map) + end if + if (.not. (associated(coord_p) .or. associated(this%lonvals))) then + deallocate(coord) + nullify(coord) + end if + ! Write out lat + if (associated(this%latmap)) then + field_lens(1) = size(this%latmap, 1) + map => this%latmap else - allocate(coord(0)) - end if - end if - vdesc => header_info%get_lat_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr) - call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing latitude') - if (.not. associated(this%latmap)) then - deallocate(map) - nullify(map) - end if - if (.not. (associated(coord_p) .or. associated(this%latvals))) then - deallocate(coord) - nullify(coord) - end if - call pio_freedecomp(File, iodesc) + field_lens(1) = 0 + allocate(map(0)) + end if + file_lens(1) = this%global_lat_size + !! XXgoldyXX: Think about caching these decomps + call cam_pio_newdecomp(iodesc, file_lens, map, pio_double) - end subroutine cam_grid_patch_write_vals + if (associated(this%latvals)) then + coord => this%latvals + else + coord_p => cam_grid_get_latvals(this%grid_id) + if (associated(coord_p)) then + coord => coord_p + else + allocate(coord(0)) + end if + end if + vdesc => header_info%get_lat_varid() + call pio_write_darray(File, vdesc, iodesc, coord, ierr) + call cam_pio_handle_error(ierr, subname//': Error writing latitude') + if (.not. associated(this%latmap)) then + deallocate(map) + nullify(map) + end if + if (.not. (associated(coord_p) .or. associated(this%latvals))) then + deallocate(coord) + nullify(coord) + end if + call pio_freedecomp(File, iodesc) - integer function cam_grid_patch_get_grid_index(this) result(index) - ! Dummy argument - class(cam_grid_patch_t) :: this + end subroutine cam_grid_patch_write_vals - ! Local variable - integer :: i + integer function cam_grid_patch_get_grid_index(this) result(index) + ! Dummy argument + class(cam_grid_patch_t) :: this - index = -1 - ! Find the grid index associated with our grid_id which is a decomp - do i = 1, cam_grid_num_grids() - if (cam_grids(i)%id == this%grid_id) then - index = i - exit - end if - end do + ! Local variable + integer :: i - end function cam_grid_patch_get_grid_index + index = -1 + ! Find the grid index associated with our grid_id which is a decomp + do i = 1, cam_grid_num_grids() + if (cam_grids(i)%id == this%grid_id) then + index = i + exit + end if + end do - subroutine cam_grid_patch_deallocate(this) - ! Dummy argument - class(cam_grid_patch_t) :: this + end function cam_grid_patch_get_grid_index - if (associated(this%mask)) then - deallocate(this%mask) - nullify(this%mask) - end if + subroutine cam_grid_patch_deallocate(this) + ! Dummy argument + class(cam_grid_patch_t) :: this - end subroutine cam_grid_patch_deallocate + if (associated(this%mask)) then + deallocate(this%mask) + nullify(this%mask) + end if - integer function cam_grid_header_info_get_gridid(this) result(id) - ! Dummy argument - class(cam_grid_header_info_t) :: this + end subroutine cam_grid_patch_deallocate - id = this%grid_id + integer function cam_grid_header_info_get_gridid(this) result(id) + ! Dummy argument + class(cam_grid_header_info_t) :: this - end function cam_grid_header_info_get_gridid + id = this%grid_id - subroutine cam_grid_header_info_set_gridid(this, id) - ! Dummy argument - class(cam_grid_header_info_t) :: this - integer, intent(in) :: id + end function cam_grid_header_info_get_gridid - this%grid_id = id + subroutine cam_grid_header_info_set_gridid(this, id) + ! Dummy argument + class(cam_grid_header_info_t) :: this + integer, intent(in) :: id - end subroutine cam_grid_header_info_set_gridid + this%grid_id = id - subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - integer, intent(in) :: hdim1 - integer, optional, intent(in) :: hdim2 + end subroutine cam_grid_header_info_set_gridid - ! Local variables - integer :: hdsize + subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) + ! Dummy arguments + class(cam_grid_header_info_t) :: this + integer, intent(in) :: hdim1 + integer, optional, intent(in) :: hdim2 - if (present(hdim2)) then - hdsize = 2 - else - hdsize = 1 - end if + ! Local variables + integer :: hdsize + character(len=*), parameter :: subname = 'cam_grid_header_info_set_hdims' - if (allocated(this%hdims)) then - ! This can happen, for instance on opening a new version of the file - if (size(this%hdims) /= hdsize) then - call endrun('cam_grid_header_info_set_hdims: hdims is wrong size') + if (present(hdim2)) then + hdsize = 2 + else + hdsize = 1 end if - else - allocate(this%hdims(hdsize)) - end if - this%hdims(1) = hdim1 - if (present(hdim2)) then - this%hdims(2) = hdim2 - end if - - end subroutine cam_grid_header_info_set_hdims - integer function cam_grid_header_info_num_hdims(this) result(num) - ! Dummy argument - class(cam_grid_header_info_t) :: this + if (allocated(this%hdims)) then + ! This can happen, for instance on opening a new version of the file + if (size(this%hdims) /= hdsize) then + call endrun(subname//': hdims is wrong size') + end if + else + allocate(this%hdims(hdsize)) + end if + this%hdims(1) = hdim1 + if (present(hdim2)) then + this%hdims(2) = hdim2 + end if - if (allocated(this%hdims)) then - num = size(this%hdims) - else - num = 0 - end if + end subroutine cam_grid_header_info_set_hdims - end function cam_grid_header_info_num_hdims + integer function cam_grid_header_info_num_hdims(this) result(num) + ! Dummy argument + class(cam_grid_header_info_t) :: this - integer function cam_grid_header_info_hdim(this, index) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - integer, intent(in) :: index + if (allocated(this%hdims)) then + num = size(this%hdims) + else + num = 0 + end if - ! Local variable - character(len=120) :: errormsg + end function cam_grid_header_info_num_hdims - if (allocated(this%hdims)) then - if ((index >= 1) .and. (index <= size(this%hdims))) then - id = this%hdims(index) + integer function cam_grid_header_info_hdim(this, index) result(id) + ! Dummy arguments + class(cam_grid_header_info_t) :: this + integer, intent(in) :: index + + ! Local variable + character(len=120) :: errormsg + + if (allocated(this%hdims)) then + if ((index >= 1) .and. (index <= size(this%hdims))) then + id = this%hdims(index) + else + write(errormsg, '(a,i0,a)') 'Index out of range, (',index,')' + call endrun('cam_grid_header_info_hdim: '//errormsg) + end if else - write(errormsg, '(a,i0,a)') 'Index out of range, (',index,')' - call endrun('cam_grid_header_info_hdim: '//errormsg) + write(errormsg, '(a)') 'No hdims allocated' + call endrun('cam_grid_header_info_hdim: '//errormsg) end if - else - write(errormsg, '(a)') 'No hdims allocated' - call endrun('cam_grid_header_info_hdim: '//errormsg) - end if - end function cam_grid_header_info_hdim + end function cam_grid_header_info_hdim - subroutine cam_grid_header_info_set_varids(this, lon_varid, lat_varid) + subroutine cam_grid_header_info_set_varids(this, lon_varid, lat_varid) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: lon_varid - type(var_desc_t), pointer :: lat_varid + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: lon_varid + type(var_desc_t), pointer :: lat_varid - if (associated(this%lon_varid)) then - deallocate(this%lon_varid) - nullify(this%lon_varid) - end if - this%lon_varid => lon_varid - if (associated(this%lat_varid)) then - deallocate(this%lat_varid) - nullify(this%lat_varid) - end if - this%lat_varid => lat_varid + if (associated(this%lon_varid)) then + deallocate(this%lon_varid) + nullify(this%lon_varid) + end if + this%lon_varid => lon_varid + if (associated(this%lat_varid)) then + deallocate(this%lat_varid) + nullify(this%lat_varid) + end if + this%lat_varid => lat_varid - end subroutine cam_grid_header_info_set_varids + end subroutine cam_grid_header_info_set_varids - function cam_grid_header_info_lon_varid(this) result(id) + function cam_grid_header_info_lon_varid(this) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: id + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: id - id => this%lon_varid + id => this%lon_varid - end function cam_grid_header_info_lon_varid + end function cam_grid_header_info_lon_varid - function cam_grid_header_info_lat_varid(this) result(id) + function cam_grid_header_info_lat_varid(this) result(id) - ! Dummy arguments - class(cam_grid_header_info_t) :: this - type(var_desc_t), pointer :: id + ! Dummy arguments + class(cam_grid_header_info_t) :: this + type(var_desc_t), pointer :: id - id => this%lat_varid + id => this%lat_varid - end function cam_grid_header_info_lat_varid + end function cam_grid_header_info_lat_varid - subroutine cam_grid_header_info_deallocate(this) - ! Dummy argument - class(cam_grid_header_info_t) :: this + subroutine cam_grid_header_info_deallocate(this) + ! Dummy argument + class(cam_grid_header_info_t) :: this - this%grid_id = -1 - if (allocated(this%hdims)) then - deallocate(this%hdims) - end if - if (associated(this%lon_varid)) then - deallocate(this%lon_varid) - nullify(this%lon_varid) - end if - if (associated(this%lat_varid)) then - deallocate(this%lat_varid) - nullify(this%lat_varid) - end if + this%grid_id = -1 + if (allocated(this%hdims)) then + deallocate(this%hdims) + end if + if (associated(this%lon_varid)) then + deallocate(this%lon_varid) + nullify(this%lon_varid) + end if + if (associated(this%lat_varid)) then + deallocate(this%lat_varid) + nullify(this%lat_varid) + end if - end subroutine cam_grid_header_info_deallocate + end subroutine cam_grid_header_info_deallocate -end module cam_grid_support + end module cam_grid_support From 8319b96769e1631aafbda0f01139c2519c634ed3 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 1 Jul 2024 11:06:28 -0600 Subject: [PATCH 39/79] remove pointers for iodesc to be passed to initdecomp --- src/utils/cam_grid_support.F90 | 23 ++++++----------------- src/utils/cam_pio_utils.F90 | 2 +- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index 0526c7f2..38423a67 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -684,11 +684,9 @@ subroutine write_horiz_coord_var(this, File, file_index) integer :: ldims(1) integer :: fdims(1) integer :: err_handling - type(io_desc_t), pointer :: iodesc + type(io_desc_t) :: iodesc integer :: file_index_loc - nullify(iodesc) - if (present(file_index)) then file_index_loc = file_index else @@ -2720,7 +2718,7 @@ subroutine write_cam_grid_val_1d_int(attr, File, file_index) ! Local variables integer :: ierr - type(io_desc_t), pointer :: iodesc + type(io_desc_t) :: iodesc integer :: file_index_loc character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' @@ -2730,21 +2728,17 @@ subroutine write_cam_grid_val_1d_int(attr, File, file_index) file_index_loc = 1 end if - nullify(iodesc) ! Since more than one grid can share an attribute, assume that if the ! vardesc is not associated, another grid write the values if (associated(attr%vardesc(file_index_loc)%p)) then ! Write out the values for this dimension variable if (associated(attr%map)) then ! This is a distributed variable, use pio_write_darray - allocate(iodesc) call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & pio_int) call pio_write_darray(File, attr%vardesc(file_index_loc)%p, & iodesc, attr%values, ierr) call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) else ! This is a local variable, pio_put_var should work fine ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, & @@ -2771,7 +2765,7 @@ subroutine write_cam_grid_val_1d_r8(attr, File, file_index) ! Local variables integer :: ierr - type(io_desc_t), pointer :: iodesc + type(io_desc_t) :: iodesc integer :: file_index_loc character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' @@ -2781,21 +2775,17 @@ subroutine write_cam_grid_val_1d_r8(attr, File, file_index) file_index_loc = 1 end if - nullify(iodesc) ! Since more than one grid can share an attribute, assume that if the ! vardesc is not associated, another grid write the values if (associated(attr%vardesc(file_index_loc)%p)) then ! Write out the values for this dimension variable if (associated(attr%map)) then ! This is a distributed variable, use pio_write_darray - allocate(iodesc) call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, & pio_double) call pio_write_darray(File, attr%vardesc(file_index_loc)%p, & iodesc, attr%values, ierr) call pio_freedecomp(File, iodesc) - deallocate(iodesc) - nullify(iodesc) else ! This is a local variable, pio_put_var should work fine ierr = pio_put_var(File, attr%vardesc(file_index_loc)%p, & @@ -2833,8 +2823,8 @@ subroutine cam_grid_write_var(File, grid_id, file_index) ! Only write if not already done if (cam_grids(gridind)%attrs_defined(file_index_loc)) then ! Write the horizontal coorinate values - call cam_grids(gridind)%lon_coord%write_var(File, file_index) - call cam_grids(gridind)%lat_coord%write_var(File, file_index) + call cam_grids(gridind)%lon_coord%write_var(File, file_index_loc) + call cam_grids(gridind)%lat_coord%write_var(File, file_index_loc) ! We will handle errors for this routine call pio_seterrorhandling(File, PIO_BCAST_ERROR, & @@ -4326,7 +4316,7 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) type(cam_grid_header_info_t), intent(inout) :: header_info ! Local variables - type(io_desc_t), pointer :: iodesc + type(io_desc_t) :: iodesc type(var_desc_t), pointer :: vdesc real(r8), pointer :: coord_p(:) real(r8), pointer :: coord(:) @@ -4340,7 +4330,6 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) nullify(coord_p) nullify(coord) nullify(map) - nullify(iodesc) if (this%grid_id /= header_info%get_gridid()) then call endrun(subname//': Grid id mismatch') end if diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90 index e66d8337..b2ea90a3 100644 --- a/src/utils/cam_pio_utils.F90 +++ b/src/utils/cam_pio_utils.F90 @@ -635,7 +635,7 @@ subroutine cam_pio_newdecomp(iodesc, dims, dof, dtype) use cam_logfile, only: cam_log_multiwrite ! Dummy arguments - type(io_desc_t), pointer :: iodesc + type(io_desc_t), intent(out) :: iodesc integer, intent(in) :: dims(:) integer(kind=PIO_OFFSET_KIND), intent(in) :: dof(:) integer, intent(in) :: dtype From 3ac1b72c931e6ac04ffbdd2535cc2ab4c050eb09 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 1 Jul 2024 11:57:44 -0600 Subject: [PATCH 40/79] Fixing pylint errors. --- tools/generate_input_to_stdnames_update.py | 83 +++++++++++----------- 1 file changed, 41 insertions(+), 42 deletions(-) diff --git a/tools/generate_input_to_stdnames_update.py b/tools/generate_input_to_stdnames_update.py index c32d41c5..0b2107df 100644 --- a/tools/generate_input_to_stdnames_update.py +++ b/tools/generate_input_to_stdnames_update.py @@ -1,60 +1,59 @@ import argparse -from collections import defaultdict -from pathlib import Path -from bs4 import BeautifulSoup import csv import re +from collections import defaultdict +from bs4 import BeautifulSoup def parse_csv(csv_filepath): - datamap = defaultdict(set) - pattern = re.compile("\w+") - print(f"Opening {csv_filepath}") - with open(csv_filepath) as csvfile: - csvdata = csv.reader(csvfile) - for row in csvdata: - inputname = row[0].split(" ")[0] - standardnameMatch = pattern.fullmatch(row[5].split(" ")[0]) - if csvdata.line_num < 432 and standardnameMatch and inputname and "Skipping" not in row[5] and "CCPP" not in row[5]: - print(f"Adding {inputname} under {standardnameMatch.string}") - # if standardnameMatch.string in datamap: - # raise Exception(f"Found duplicate standard name {standardnameMatch.string} on line {csvdata.line_num}") - datamap[standardnameMatch.string].add(inputname) - return datamap + datamap = defaultdict(set) + pattern = re.compile("\w+") + print(f"Opening {csv_filepath}") + with open(csv_filepath, encoding='ascii') as csvfile: + csvdata = csv.reader(csvfile) + for row in csvdata: + inputname = row[0].split(" ")[0] + standardname_match = pattern.fullmatch(row[5].split(" ")[0]) + if csvdata.line_num < 432 and standardname_match and inputname and "Skipping" not in row[5] and "CCPP" not in row[5]: + print(f"Adding {inputname} under {standardname_match.string}") + # if standardname_match.string in datamap: + # raise Exception(f"Found duplicate standard name {standardname_match.string} on line {csvdata.line_num}") + datamap[standardname_match.string].add(inputname) + return datamap def generate_stdname_xml(current_dict, output_filename): - xmltree = BeautifulSoup(features="xml") - - entries = xmltree.new_tag("entries") - for k, v in current_dict.items(): - entry = xmltree.new_tag("entry") - entry["stdname"] = k - names = xmltree.new_tag("ic_file_input_names") - for name in v: - namenode = xmltree.new_tag("ic_file_input_name") - namenode.string = name - names.append(namenode) - entry.append(names) - entries.append(entry) - xmltree.append(entries) - with open(output_filename, "w") as xmlout: - print(f"Creating new xml file : {output_filename}") - xmlout.write(xmltree.prettify()) + xmltree = BeautifulSoup(features="xml") + + entries = xmltree.new_tag("entries") + for k, v in current_dict.items(): + entry = xmltree.new_tag("entry") + entry["stdname"] = k + names = xmltree.new_tag("ic_file_input_names") + for name in v: + namenode = xmltree.new_tag("ic_file_input_name") + namenode.string = name + names.append(namenode) + entry.append(names) + entries.append(entry) + xmltree.append(entries) + with open(output_filename, "w", encoding='ascii') as xmlout: + print(f"Creating new xml file : {output_filename}") + xmlout.write(xmltree.prettify()) def main(): - parser = argparse.ArgumentParser(description='') - parser.add_argument('--csv-file', type=str, default='CCPP Standard Names - Sheet1.csv', help='') - parser.add_argument('--current-map', type=str, default='stdnames_to_inputnames_dictionary.xml', help='') - parser.add_argument('--output-map', type=str, default='stdnames_to_inputnames_dictionary_new.xml', help='') + parser = argparse.ArgumentParser(description='') + parser.add_argument('--csv-file', type=str, default='CCPP Standard Names - Sheet1.csv', help='') + parser.add_argument('--current-map', type=str, default='stdnames_to_inputnames_dictionary.xml', help='') + parser.add_argument('--output-map', type=str, default='stdnames_to_inputnames_dictionary_new.xml', help='') - args = parser.parse_args() + args = parser.parse_args() - current_csv_entries = parse_csv(args.csv_file) - generate_stdname_xml(current_csv_entries, args.output_map) + current_csv_entries = parse_csv(args.csv_file) + generate_stdname_xml(current_csv_entries, args.output_map) -if __name__=="__main__": +if __name__=="__main__": main() From 04fd2baf9826ab7671b67f79f9f03513bef7092a Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 5 Jul 2024 15:30:48 -0600 Subject: [PATCH 41/79] fix for intel compiler; add "allocatable" for nl arrays --- src/history/cam_hist_file.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 448781e3..b5579a13 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1631,11 +1631,11 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & ! Dummy arguments integer, intent(inout) :: unitn type(hist_file_t), intent(inout) :: hfile_config - character(len=*), intent(inout) :: hist_inst_fields(:) - character(len=*), intent(inout) :: hist_avg_fields(:) - character(len=*), intent(inout) :: hist_min_fields(:) - character(len=*), intent(inout) :: hist_max_fields(:) - character(len=*), intent(inout) :: hist_var_fields(:) + character(len=*), allocatable, intent(inout) :: hist_inst_fields(:) + character(len=*), allocatable, intent(inout) :: hist_avg_fields(:) + character(len=*), allocatable, intent(inout) :: hist_min_fields(:) + character(len=*), allocatable, intent(inout) :: hist_max_fields(:) + character(len=*), allocatable, intent(inout) :: hist_var_fields(:) ! Local variables (namelist) character(len=vlen) :: hist_volume ! h# ir i, not config number character(len=vlen) :: hist_precision From a1a520218e7c364e2d31404c7bdaecd0acdb9168 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 5 Jul 2024 15:40:25 -0600 Subject: [PATCH 42/79] specify character len --- src/history/cam_hist_file.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index b5579a13..49b36893 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1631,11 +1631,11 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & ! Dummy arguments integer, intent(inout) :: unitn type(hist_file_t), intent(inout) :: hfile_config - character(len=*), allocatable, intent(inout) :: hist_inst_fields(:) - character(len=*), allocatable, intent(inout) :: hist_avg_fields(:) - character(len=*), allocatable, intent(inout) :: hist_min_fields(:) - character(len=*), allocatable, intent(inout) :: hist_max_fields(:) - character(len=*), allocatable, intent(inout) :: hist_var_fields(:) + character(len=max_fldlen), allocatable, intent(inout) :: hist_inst_fields(:) + character(len=max_fldlen), allocatable, intent(inout) :: hist_avg_fields(:) + character(len=max_fldlen), allocatable, intent(inout) :: hist_min_fields(:) + character(len=max_fldlen), allocatable, intent(inout) :: hist_max_fields(:) + character(len=max_fldlen), allocatable, intent(inout) :: hist_var_fields(:) ! Local variables (namelist) character(len=vlen) :: hist_volume ! h# ir i, not config number character(len=vlen) :: hist_precision From 8191b822c4c802ce9c7cbc5f066f1eb94399a95e Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 5 Jul 2024 16:27:34 -0600 Subject: [PATCH 43/79] fix broadcasts for arrays of character arrays --- src/history/cam_hist_file.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 49b36893..3870fbcb 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1736,31 +1736,31 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & call MPI_Bcast(num_fields_var, 1, MPI_INTEGER, masterprocid, mpicom, ierr) ! Broadcast namelist data if (num_fields_inst > 0) then - call MPI_Bcast(hist_inst_fields(:), num_fields_inst, MPI_CHARACTER, & + call MPI_Bcast(hist_inst_fields(:), max_fldlen*num_fields_inst, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_avg > 0) then call endrun(subname//"ERROR, average fields not yet implemented", & file=__FILE__, line=__LINE__) - call MPI_Bcast(hist_avg_fields(:), num_fields_avg, MPI_CHARACTER, & + call MPI_Bcast(hist_avg_fields(:), max_fldlen*num_fields_avg, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_min > 0) then call endrun(subname//"ERROR, minimum fields not yet implemented", & file=__FILE__, line=__LINE__) - call MPI_Bcast(hist_min_fields(:), num_fields_min, MPI_CHARACTER, & + call MPI_Bcast(hist_min_fields(:), max_fldlen*num_fields_min, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_max > 0) then call endrun(subname//"ERROR, maximum fields not yet implemented", & file=__FILE__, line=__LINE__) - call MPI_Bcast(hist_max_fields(:), num_fields_max, MPI_CHARACTER, & + call MPI_Bcast(hist_max_fields(:), max_fldlen*num_fields_max, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if if (num_fields_var > 0) then call endrun(subname//"ERROR, standard deviation fields not yet implemented", & file=__FILE__, line=__LINE__) - call MPI_Bcast(hist_var_fields(:), num_fields_var, MPI_CHARACTER, & + call MPI_Bcast(hist_var_fields(:), max_fldlen*num_fields_var, MPI_CHARACTER, & masterprocid, mpicom, ierr) end if call MPI_Bcast(hist_volume, vlen, MPI_CHARACTER, masterprocid, & From 188596107dfc1cb7db8fb74a8b412cb77f49db70 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 5 Jul 2024 23:00:04 -0600 Subject: [PATCH 44/79] fix frequency calculations; couple fixes for output --- cime_config/hist_config.py | 16 +++---- src/history/cam_hist_file.F90 | 72 +++++++++++++++++++++++++++--- src/history/cam_history.F90 | 84 ++++++++++++++++++++++++----------- 3 files changed, 134 insertions(+), 38 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index c274685f..47073653 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -590,7 +590,7 @@ def add_inst_fields(self, fields, pobj, logger): else: emsg = "Attempt to add 'inst' fields to a history volume with " \ "non-'inst' fields" - pobj.add_syntax_error(emsg) + pobj.add_syntax_err(emsg) # end if return self.__last_field_ok @@ -606,7 +606,7 @@ def add_avg_fields(self, fields, pobj, logger): else: emsg = "Attempt to add 'avg' fields to a history volume with " \ "'inst' fields" - pobj.add_syntax_error(emsg) + pobj.add_syntax_err(emsg) # end if return not self.__last_field_only @@ -621,7 +621,7 @@ def add_min_fields(self, fields, pobj, logger): else: emsg = "Attempt to add 'min' fields to a history volume with " \ "'inst' fields" - pobj.add_syntax_error(emsg) + pobj.add_syntax_err(emsg) # end if return not self.__last_field_only @@ -636,7 +636,7 @@ def add_max_fields(self, fields, pobj, logger): else: emsg = "Attempt to add 'max' fields to a history volume with " \ "'inst' fields" - pobj.add_syntax_error(emsg) + pobj.add_syntax_err(emsg) # end if return not self.__last_field_only @@ -651,7 +651,7 @@ def add_var_fields(self, fields, pobj, logger): else: emsg = "Attempt to add 'var' fields to a history volume with " \ "'inst' fields" - pobj.add_syntax_error(emsg) + pobj.add_syntax_err(emsg) # end if return not self.__last_field_only @@ -694,7 +694,7 @@ def set_precision(self, prec, pobj, logger): return True # end if emsg = "Attempt to set unrecognized precision, '{}'" - pobj.add_syntax_error(emsg.format(prec)) + pobj.add_syntax_err(emsg.format(prec)) return False @property @@ -723,7 +723,7 @@ def set_max_frames(self, nframes, pobj, logger): # end if else: emsg = "Attempt to set max frames to '{}', must be positive integer" - pobj.add_syntax_error(emsg.format(nframes)) + pobj.add_syntax_err(emsg.format(nframes)) # end if return nframes_ok @@ -765,7 +765,7 @@ def set_output_frequency(self, ofreq, pobj, logger): return True # end if emsg = "Attempt to set unrecognized output_frequency, '{}'" - pobj.add_syntax_error(emsg.format(ofreq)) + pobj.add_syntax_err(emsg.format(ofreq)) return False @property diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 3870fbcb..3d1f66a0 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -64,6 +64,9 @@ module cam_hist_file logical, private :: has_instantaneous = .false. logical, private :: has_accumulated = .false. logical, private :: write_nstep0 = .false. + integer, private :: last_month_written + integer, private :: last_year_written + logical, private :: files_open = .false. type(interp_info_t), pointer, private :: interp_info => NULL() character(len=CL), allocatable, private :: file_names(:) ! PIO IDs @@ -94,6 +97,8 @@ module cam_hist_file procedure :: get_volume => config_volume procedure :: get_filenames => config_get_filenames procedure :: get_filename_spec => config_get_filename_spec + procedure :: get_last_month_written => config_get_last_month_written + procedure :: get_last_year_written => config_get_last_year_written procedure :: precision => config_precision procedure :: max_frame => config_max_frame procedure :: get_num_samples => config_get_num_samples @@ -106,6 +111,7 @@ module cam_hist_file procedure :: is_hist_restart_file => config_restart_file procedure :: do_write_nstep0 => config_do_write_nstep0 procedure :: file_is_setup => config_file_is_setup + procedure :: are_files_open => config_files_open ! Actions procedure :: reset => config_reset procedure :: configure => config_configure @@ -113,6 +119,8 @@ module cam_hist_file procedure :: set_beg_time => config_set_beg_time procedure :: set_end_time => config_set_end_time procedure :: set_filenames => config_set_filenames + procedure :: set_last_month_written => config_set_last_month_written + procedure :: set_last_year_written => config_set_last_year_written procedure :: set_up_fields => config_set_up_fields procedure :: find_in_field_list => config_find_in_field_list procedure :: define_file => config_define_file @@ -184,6 +192,28 @@ end subroutine config_set_filenames ! ======================================================================== + subroutine config_set_last_month_written(this, last_month_written) + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: last_month_written + + this%last_month_written = last_month_written + + end subroutine config_set_last_month_written + + ! ======================================================================== + + subroutine config_set_last_year_written(this, last_year_written) + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + integer, intent(in) :: last_year_written + + this%last_year_written = last_year_written + + end subroutine config_set_last_year_written + + ! ======================================================================== + function config_get_filenames(this) result(cfiles) ! Dummy arguments class(hist_file_t), intent(in) :: this @@ -206,6 +236,26 @@ end function config_get_filename_spec ! ======================================================================== + integer function config_get_last_month_written(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_get_last_month_written = this%last_month_written + + end function config_get_last_month_written + + ! ======================================================================== + + integer function config_get_last_year_written(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_get_last_year_written = this%last_year_written + + end function config_get_last_year_written + + ! ======================================================================== + function config_precision(this) result(cprec) ! Dummy arguments class(hist_file_t), intent(in) :: this @@ -363,6 +413,16 @@ end function config_file_is_setup ! ======================================================================== + logical function config_files_open(this) + ! Dummy argument + class(hist_file_t), intent(in) :: this + + config_files_open = this%files_open + + end function config_files_open + + ! ======================================================================== + subroutine config_reset(this) ! Dummy argument class(hist_file_t), intent(inout) :: this @@ -903,6 +963,8 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) this%file_names(accumulated_file_index), amode) end if + this%files_open = .true. + allocate(header_info(size(this%grids, 1)), stat=ierr) call check_allocate(ierr, subname, 'header_info', & file=__FILE__, line=__LINE__-1) @@ -1296,7 +1358,7 @@ end subroutine config_define_file ! ======================================================================== - subroutine config_write_time_dependent_variables(this, volume_index, restart) + subroutine config_write_time_dependent_variables(this, restart) use pio, only: pio_put_var, pio_file_is_open use time_manager, only: get_nstep, get_curr_date, get_curr_time use time_manager, only: set_date_from_time_float, get_step_size @@ -1307,7 +1369,6 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) use cam_pio_utils, only: cam_pio_handle_error ! Dummy arguments class(hist_file_t), intent(inout) :: this - integer, intent(in) :: volume_index logical, intent(in) :: restart ! Local variables @@ -1348,13 +1409,13 @@ subroutine config_write_time_dependent_variables(this, volume_index, restart) do split_file_index = 1, max_split_files if (pio_file_is_open(this%hist_files(split_file_index))) then if (split_file_index == instantaneous_file_index) then - write(iulog,200) num_samples+1,'instantaneous',volume_index-1,yr,mon,day,ncsec(split_file_index) + write(iulog,200) num_samples+1,'instantaneous',trim(this%volume),yr,mon,day,ncsec(split_file_index) else - write(iulog,200) num_samples+1,'accumulated',volume_index-1,yr_mid,mon_mid,day_mid,ncsec(split_file_index) + write(iulog,200) num_samples+1,'accumulated',trim(this%volume),yr_mid,mon_mid,day_mid,ncsec(split_file_index) end if end if 200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & - i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + a,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) end do write(iulog,*) end if @@ -1570,6 +1631,7 @@ subroutine config_close_files(this) if (allocated(this%file_names)) then deallocate(this%file_names) end if + this%files_open = .false. end subroutine config_close_files diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 92ef8cc2..8ab25c5a 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -87,7 +87,8 @@ subroutine history_write_files() ! fields to those files ! !----------------------------------------------------------------------- - use time_manager, only: set_date_from_time_float, get_nstep + use time_manager, only: get_curr_date, get_nstep + use time_manager, only: get_step_size use cam_grid_support, only: max_split_files use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -96,32 +97,40 @@ subroutine history_write_files() character(len=cl) :: file_names(max_split_files) character(len=cl) :: prev_file_names(max_split_files) integer :: yr, mon, day - integer :: yr_mid, mon_mid, day_mid - integer :: nstep - integer :: ncdate, ncdate_mid - integer :: ncsec, ncsec_mid - integer :: ndcur, nscur + integer :: nstep, dtime, nstep_freq + integer :: ncsec integer :: num_samples - real(r8) :: time, beg_time - real(r8) :: time_interval(2) - integer :: file_idx, split_file_idx, prev_file_idx, idx + integer :: file_idx, prev_file_idx, idx integer :: out_frq_mult + integer :: last_month_written + integer :: last_year_written character(len=8) :: out_frq_type logical :: write_history, write_nstep0, duplicate character(len=cl) :: filename_spec, prev_filename_spec - integer :: start, count1 logical :: restart + logical :: month_changed ! Get nstep nstep = get_nstep() + ! Get timestep size (in seconds) + dtime = get_step_size() + + ! Get current time + call get_curr_date(yr, mon, day, ncsec) + ! peverwhee - TODO: remove when restarts are implemented restart = .false. ! Loop over history volumes do file_idx = 1, size(hist_configs) ! Determine if it's time to write! + if (nstep == 0) then + call hist_configs(file_idx)%set_last_year_written(yr) + call hist_configs(file_idx)%set_last_month_written(mon) + end if write_history = .false. + month_changed = .false. call hist_configs(file_idx)%output_freq_separate(out_frq_mult, out_frq_type) select case(trim(out_frq_type)) case('step') @@ -129,40 +138,60 @@ subroutine history_write_files() write_history = .true. end if case('second') - if (mod(ncsec, out_frq_mult) == 0) then + nstep_freq = out_frq_mult / dtime + if (mod(nstep, nstep_freq) == 0) then write_history = .true. end if case('minute') - if (mod(ncsec, out_frq_mult * 60) == 0) then + nstep_freq = nint((out_frq_mult * 60._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then write_history = .true. end if case('hour') - if (mod(ncsec, out_frq_mult * 3600) == 0) then + nstep_freq = nint((out_frq_mult * 3600._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then write_history = .true. end if case('day') - if (mod(day, out_frq_mult) == 0 .and. ncsec == 0) then + nstep_freq = nint((out_frq_mult * 86400._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then write_history = .true. end if case('month') - if (mod(mon, out_frq_mult) == 0 .and. ncsec == 0 .and. day == 1) then + ! Determine if it has been out_frq_mult months since the + ! last write + last_month_written = hist_configs(file_idx)%get_last_month_written() + if (mon < last_month_written) then + mon = mon + 12 + month_changed = .true. + end if + if ((mon - last_month_written == out_frq_mult) .and. ncsec == 0 .and. day == 1) then write_history = .true. + if (month_changed) then + last_month_written = mon - 12 + else + last_month_written = mon + end if + call hist_configs(file_idx)%set_last_month_written(last_month_written) end if case('year') - if (mod(yr, out_frq_mult) == 0 .and. ncsec == 0 .and. day == 1 .and. & + ! Determine if it has been out_frq_mult years since the + ! last write + last_year_written = hist_configs(file_idx)%get_last_year_written() + if ((yr - last_year_written == out_frq_mult) .and. ncsec == 0 .and. day == 1 .and. & mon == 1) then write_history = .true. + call hist_configs(file_idx)%set_last_year_written(yr) end if end select + write_nstep0 = hist_configs(file_idx)%do_write_nstep0() + if (write_nstep0 .and. nstep == 0) then + write_history = .true. + end if if (.not. write_history) then ! Don't write this volume! cycle end if - write_nstep0 = hist_configs(file_idx)%do_write_nstep0() - if (nstep == 0 .and. .not. write_nstep0) then - ! Don't write the first nstep=0 sample - cycle - end if num_samples = hist_configs(file_idx)%get_num_samples() if (mod(num_samples, hist_configs(file_idx)%max_frame()) == 0) then ! This if the first write to this file - set up volume @@ -194,7 +223,7 @@ subroutine history_write_files() end if call hist_configs(file_idx)%define_file(restart, logname, host, model_doi_url) end if - call hist_configs(file_idx)%write_time_dependent_variables(file_idx, restart) + call hist_configs(file_idx)%write_time_dependent_variables(restart) end do end subroutine history_write_files @@ -749,7 +778,7 @@ subroutine history_wrap_up(restart_write, last_timestep) ! Local variables integer :: yr, mon, day, ncsec integer :: ndcur, nscur, nstep - integer :: file_idx, split_file_idx, field_idx + integer :: file_idx integer :: num_samples, max_frames logical :: full real(r8) :: tday ! Model day number for printout @@ -777,7 +806,8 @@ subroutine history_wrap_up(restart_write, last_timestep) if (mod(num_samples, max_frames) == 0 .and. num_samples > 0) then full = .true. end if - if (full .or. (last_timestep .and. num_samples >= 1)) then + if ((full .or. (last_timestep .and. num_samples >= 1)) .and. & + hist_configs(file_idx)%are_files_open()) then ! ! Dispose history file ! @@ -794,7 +824,11 @@ subroutine history_wrap_up(restart_write, last_timestep) else write(iulog,*)' Auxiliary history file ', hist_configs(file_idx)%get_volume() end if - write(iulog,9003)nstep,mod(num_samples, max_frames),tday + if (full) then + write(iulog,9003) nstep, max_frames, tday + else + write(iulog,9003) nstep, mod(num_samples, max_frames), tday + end if write(iulog,9004) end if end if From f7e9d1fe7cee43d22ab719d294506a8bc1a609fe Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 8 Jul 2024 13:43:01 -0600 Subject: [PATCH 45/79] allow instantaneous and accumulated fields on same volume --- cime_config/hist_config.py | 62 +++++++---------------------------- src/control/cam_comp.F90 | 1 + src/history/cam_hist_file.F90 | 4 +-- 3 files changed, 15 insertions(+), 52 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 47073653..8cef329e 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -291,7 +291,8 @@ def _add_item(self, item, comp_lists, pobj, logger): iadd = str(item).strip() do_add = True for hflist in comp_lists: - if iadd in hflist.__field_names: + if iadd in hflist.__field_names and self.desc == hflist.desc: + # Field is a duplicate (both the name and the type match) do_add = False ctx = context_string(pobj) logger.warning(hflist.__dup_field_msg.format(iadd, hflist.desc, @@ -386,7 +387,6 @@ def output_nl_fieldlist(self, outfile, field_varname): quotelist = ["'{}{}'".format(x, ' '*(self.max_len - len(x))) for x in self.__field_names[fld_beg:fld_end+1]] outfile.write(f"{lhs}{', '.join(quotelist)}{comma}\n") -# outfile.write(f'{lhs}\"{", ".join(self.__field_names[fld_beg:fld_end+1])}{comma}\"\n') lhs = blank_lhs # end while # end if @@ -574,86 +574,48 @@ def __init__(self, volume): self.__interp_grid = self.__UNSET_C self.__interp_type = self.__UNSET_C self.__write_nstep0 = ".false." - # Utility variables - self.__last_field_ok = True - self.__last_field_only = False def add_inst_fields(self, fields, pobj, logger): """Add one or more instantaneous (last sampled value)_fields to this HistoryVolConfig object. Return True if it was okay to add to list of last fields. """ - if self.__last_field_ok: - add_ok = self.__inst_fields.add_fields(fields, self.__all_fields, + add_ok = self.__inst_fields.add_fields(fields, self.__all_fields, pobj, logger) - self.__last_field_only |= add_ok - else: - emsg = "Attempt to add 'inst' fields to a history volume with " \ - "non-'inst' fields" - pobj.add_syntax_err(emsg) - # end if - return self.__last_field_ok + return add_ok def add_avg_fields(self, fields, pobj, logger): """Add one or more time-averaged fields to this HistoryVolConfig object. Return True if it was okay to add to list of avg fields. """ - if not self.__last_field_only: - add_ok = self.__avg_fields.add_fields(fields, self.__all_fields, + add_ok = self.__avg_fields.add_fields(fields, self.__all_fields, pobj, logger) - self.__last_field_ok &= (not add_ok) - else: - emsg = "Attempt to add 'avg' fields to a history volume with " \ - "'inst' fields" - pobj.add_syntax_err(emsg) - # end if - return not self.__last_field_only + return add_ok def add_min_fields(self, fields, pobj, logger): """Add one or more min_fields to this HistoryVolConfig object. Return True if it was okay to add to list of min fields. """ - if not self.__last_field_only: - add_ok = self.__min_fields.add_fields(fields, self.__all_fields, + add_ok = self.__min_fields.add_fields(fields, self.__all_fields, pobj, logger) - self.__last_field_ok &= (not add_ok) - else: - emsg = "Attempt to add 'min' fields to a history volume with " \ - "'inst' fields" - pobj.add_syntax_err(emsg) - # end if - return not self.__last_field_only + return add_ok def add_max_fields(self, fields, pobj, logger): """Add one or more max_fields to this HistoryVolConfig object. Return True if it was okay to add to list of max fields. """ - if not self.__last_field_only: - add_ok = self.__max_fields.add_fields(fields, self.__all_fields, + add_ok = self.__max_fields.add_fields(fields, self.__all_fields, pobj, logger) - self.__last_field_ok &= (not add_ok) - else: - emsg = "Attempt to add 'max' fields to a history volume with " \ - "'inst' fields" - pobj.add_syntax_err(emsg) - # end if - return not self.__last_field_only + return add_ok def add_var_fields(self, fields, pobj, logger): """Add one or more var_fields to this HistoryVolConfig object. Return True if it was okay to add to list of var fields. """ - if not self.__last_field_only: - add_ok = self.__var_fields.add_fields(fields, self.__all_fields, + add_ok = self.__var_fields.add_fields(fields, self.__all_fields, pobj, logger) - self.__last_field_ok &= (not add_ok) - else: - emsg = "Attempt to add 'var' fields to a history volume with " \ - "'inst' fields" - pobj.add_syntax_err(emsg) - # end if - return not self.__last_field_only + return add_ok def remove_fields(self, fields, pobj, logger): """Remove each field in from whatever list it is on. diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index 5dc1b35c..f2dfeeb1 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -445,6 +445,7 @@ subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check) logical, intent(in) :: rstwr ! write restart file logical, intent(in) :: nlend ! this is final timestep !Flag for whether a snapshot (ncdata) check should be run or not + ! - flag is true if this is not the last step logical, intent(in) :: do_ncdata_check if (do_ncdata_check) then diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 3d1f66a0..5142cb1f 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1987,11 +1987,11 @@ subroutine hist_read_namelist_config(filename, config_arr) character(len=max_str) :: config_line character(len=CL) :: errmsg character(len=*), parameter :: subname = 'read_config_file' - ! Variables for reading a namelist entry -! nullify(config_arr) + ! Variables for reading a namelist entry unitn = -1 ! Prevent reads on error or wrong tasks ierr = 0 + errmsg = '' if (masterproc) then inquire(file=trim(filename), exist=filefound) From 60244520674acc853d2ac0479ce9f77446aad893 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 8 Jul 2024 14:36:48 -0600 Subject: [PATCH 46/79] Removing anomalous backslash in regex string by using raw string. --- tools/generate_input_to_stdnames_update.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/generate_input_to_stdnames_update.py b/tools/generate_input_to_stdnames_update.py index 0b2107df..541ad514 100644 --- a/tools/generate_input_to_stdnames_update.py +++ b/tools/generate_input_to_stdnames_update.py @@ -7,7 +7,7 @@ def parse_csv(csv_filepath): datamap = defaultdict(set) - pattern = re.compile("\w+") + pattern = re.compile(r"\w+") print(f"Opening {csv_filepath}") with open(csv_filepath, encoding='ascii') as csvfile: csvdata = csv.reader(csvfile) From 498dbbbc619456ed262120e692be0f5dfd7f6d25 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 8 Jul 2024 16:00:36 -0600 Subject: [PATCH 47/79] code cleanup --- src/control/cam_instance.F90 | 50 +++++----- src/utils/cam_abortutils.F90 | 172 ++++++++++++++++++++++++++++++++--- src/utils/cam_pio_utils.F90 | 109 +--------------------- 3 files changed, 183 insertions(+), 148 deletions(-) diff --git a/src/control/cam_instance.F90 b/src/control/cam_instance.F90 index 1d8e514d..02e77baf 100644 --- a/src/control/cam_instance.F90 +++ b/src/control/cam_instance.F90 @@ -1,34 +1,30 @@ module cam_instance - implicit none - private - save + implicit none + public - public :: cam_instance_init + integer , public :: atm_id + integer , public :: inst_index + character(len=16), public :: inst_name + character(len=16), public :: inst_suffix - integer, public :: atm_id - integer, public :: inst_index - character(len=16), public :: inst_name - character(len=16), public :: inst_suffix - -!============================================================================== +!=============================================================================== CONTAINS -!============================================================================== - - subroutine cam_instance_init(atm_id_in, inst_name_in, inst_index_in, & - inst_suffix_in) - ! Dummy arguments - integer, intent(in) :: atm_id_in - character(len=*), intent(in) :: inst_name_in - integer, intent(in) :: inst_index_in - character(len=*), intent(in) :: inst_suffix_in - - ! The following sets the module variables - atm_id = atm_id_in - inst_name = inst_name_in - inst_index = inst_index_in - inst_suffix = inst_suffix_in - - end subroutine cam_instance_init +!=============================================================================== + + subroutine cam_instance_init(atm_id_in, inst_name_in, inst_index_in, inst_suffix_in) + + integer , intent(in) :: atm_id_in + character(len=*) , intent(in) :: inst_name_in + integer , intent(in) :: inst_index_in + character(len=*) , intent(in) :: inst_suffix_in + + ! The following sets the module variables + atm_id = atm_id_in + inst_name = inst_name_in + inst_index = inst_index_in + inst_suffix = inst_suffix_in + + end subroutine cam_instance_init end module cam_instance diff --git a/src/utils/cam_abortutils.F90 b/src/utils/cam_abortutils.F90 index 5b0aace7..b2ac2fc2 100644 --- a/src/utils/cam_abortutils.F90 +++ b/src/utils/cam_abortutils.F90 @@ -12,8 +12,20 @@ module cam_abortutils save public :: endrun + public :: safe_endrun public :: check_allocate - public :: check_endrun ! Stub needed for testing + public :: cam_register_open_file + public :: cam_register_close_file + + type :: open_file_pointer + type(file_desc_t), pointer :: file_desc => NULL() + character(len=max_chars) :: file_name = '' + type(open_file_pointer), pointer :: next => NULL() + end type open_file_pointer + + type(open_file_pointer), pointer :: open_files_head => NULL() + type(open_file_pointer), pointer :: open_files_tail => NULL() + type(open_file_pointer), pointer :: open_files_pool => NULL() CONTAINS @@ -35,10 +47,10 @@ subroutine check_allocate(errcode, subname, fieldname, file, line) call shr_mem_getusage(mem_hw_val, mem_val) ! Write error message with memory stats - write(abort_msg, '(4a,i0,a,f10.2,a,f10.2,a)') & - trim(subname), ": Allocate of '", & - trim(fieldname), "' failed with code ", errcode, & - ". Memory highwater is ", mem_hw_val, & + write(abort_msg, '(4a,i0,a,f10.2,a,f10.2,a)') & + trim(subname), ": Allocate of '", & + trim(fieldname), "' failed with code ", errcode, & + ". Memory highwater is ", mem_hw_val, & " mb, current memory usage is ", mem_val, " mb" ! End the simulation @@ -47,6 +59,110 @@ subroutine check_allocate(errcode, subname, fieldname, file, line) end subroutine check_allocate + subroutine cam_register_open_file(file, file_name) + ! Dummy arguments + type(file_desc_t), target, intent(in) :: file + character(len=*), intent(in) :: file_name + ! Local variables + type(open_file_pointer), pointer :: of_ptr + type(open_file_pointer), pointer :: of_new + character(len=*), parameter :: subname = 'cam_register_open_file' + + nullify(of_new) + ! First, make sure we do not have this file + of_ptr => open_files_head + do while (associated(of_ptr)) + if (file%fh == of_ptr%file_desc%fh) then + call endrun(subname//': Cannot register '//trim(file_name)//', file already open as '//trim(of_ptr%file_name)) + end if + of_ptr => of_ptr%next + end do + ! If we get here, go ahead and register the file + if (associated(open_files_pool)) then + of_new => open_files_pool + of_new%file_desc = file + of_new%file_name = file_name + allocate(open_files_pool%next) + open_files_pool%next => open_files_pool + else + allocate(of_new) + allocate(of_new%file_desc) + of_new%file_desc = file + of_new%file_name = file_name + open_files_pool => of_new + end if + open_files_tail => of_new + if (.not. associated(open_files_head)) then + open_files_head => of_new + end if + end subroutine cam_register_open_file + + subroutine cam_register_close_file(file, log_shutdown_in) + ! Dummy arguments + type(file_desc_t), target, intent(in) :: file + character(len=*), optional, intent(in) :: log_shutdown_in + ! Local variables + type(open_file_pointer), pointer :: of_ptr + type(open_file_pointer), pointer :: of_prev + character(len=msg_len) :: log_shutdown + character(len=*), parameter :: subname = 'cam_register_close_file' + logical :: file_loop_var + + nullify(of_prev) + ! Are we going to log shutdown events? + if (present(log_shutdown_in)) then + log_shutdown = trim(log_shutdown_in) + else + log_shutdown = '' + end if + ! Look to see if we have this file + of_ptr => open_files_head + + !Set while-loop control variable + file_loop_var = .false. + if (associated(of_ptr)) then + if(associated(of_ptr%file_desc)) then + file_loop_var = .true. + end if + end if + + do while (file_loop_var) + if (file%fh == of_ptr%file_desc%fh) then + ! Remove this file from the list + if (associated(of_prev)) then + of_prev%next => of_ptr%next + else + open_files_head => of_ptr%next + end if + ! Log closure? + ! Note, no masterproc control because this could be any PE + if (len_trim(log_shutdown) > 0) then + write(iulog, '(a,": ",a," of ",a)') subname, & + trim(log_shutdown), trim(of_ptr%file_name) + call shr_sys_flush(iulog) + end if + ! Push this object on to free pool + nullify(of_ptr%file_desc) + of_ptr%next => open_files_pool + open_files_pool => of_ptr + nullify(of_ptr) + exit + else + of_prev => of_ptr + of_ptr => of_ptr%next + end if + !Check if loop needs to continue + if (.not.associated(of_ptr)) then + file_loop_var = .false. + else + if(.not.associated(of_ptr%file_desc)) then + file_loop_var = .false. + end if + end if + + end do + end subroutine cam_register_close_file + subroutine endrun(message, file, line) ! Parallel emergency stop ! Dummy arguments @@ -68,14 +184,44 @@ subroutine endrun(message, file, line) end subroutine endrun - logical function check_endrun(test_desc, output) - character(len=*), optional, intent(in) :: test_desc - integer, optional, intent(in) :: output - - ! Return .true. if an endrun message has been created - ! Stub, always return .false. - check_endrun = .false. + subroutine safe_endrun(message, file, line) + ! Sequential/global emergency stop + use pio, only : pio_closefile + ! Dummy arguments + character(len=*), intent(in) :: message + character(len=*), optional, intent(in) :: file + integer, optional, intent(in) :: line - end function check_endrun + ! Local variables + character(len=max_chars) :: abort_msg + type(open_file_pointer), pointer :: of_ptr + logical :: keep_loop + + ! First, close all open PIO files + of_ptr => open_files_head + + !Check if needed pointers are associated: + keep_loop = .false. + if (associated(of_ptr)) then + if (associated(of_ptr%file_desc)) then + keep_loop = .true. + end if + end if + do while (keep_loop) + call pio_closefile(of_ptr%file_desc) + call cam_register_close_file(of_ptr%file_desc, & + log_shutdown_in="Emergency close") + of_ptr => of_ptr%next + !End loop if new pointers aren't associated: + if (.not. associated(of_ptr)) then + keep_loop = .false. + else if (.not. associated(of_ptr%file_desc)) then + keep_loop = .false. + end if + end do + + call endrun(message, file, line) + + end subroutine safe_endrun end module cam_abortutils diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90 index b2ea90a3..5e0e5ebe 100644 --- a/src/utils/cam_pio_utils.F90 +++ b/src/utils/cam_pio_utils.F90 @@ -101,7 +101,6 @@ module cam_pio_utils end interface cam_permute_array interface cam_pio_dump_field - module procedure dump_field_1d_d module procedure dump_field_2d_d module procedure dump_field_3d_d module procedure dump_field_4d_d @@ -1317,7 +1316,7 @@ logical function cam_pio_fileexists(fname) end if ! Back to whatever error handling was running before this routine - call pio_seterrorhandling(pio_subsystem, err_handling) + call pio_seterrorhandling(File, err_handling) end function cam_pio_fileexists @@ -1440,112 +1439,6 @@ subroutine find_dump_filename(fieldname, filename) end subroutine find_dump_filename !=========================================================================== - subroutine dump_field_1d_d(fieldname, dim1b, dim1e, field, & - compute_maxdim_in, fill_value) - use pio, only: file_desc_t, var_desc_t, io_desc_t - use pio, only: pio_offset_kind, pio_enddef - use pio, only: pio_double, pio_int, pio_write_darray - use pio, only: pio_put_att, pio_initdecomp, pio_freedecomp - - use mpi, only: mpi_max, mpi_integer - use spmd_utils, only: iam, npes, mpicom - - ! Dummy arguments - character(len=*), intent(in) :: fieldname - integer, intent(in) :: dim1b - integer, intent(in) :: dim1e - real(r8), target, intent(in) :: field(dim1b:dim1e) - logical, optional, intent(in) :: compute_maxdim_in - real(r8), optional, intent(in) :: fill_value - - ! Local variables - type(file_desc_t) :: file - type(var_desc_t) :: vdesc - type(var_desc_t) :: bnddesc - type(io_desc_t) :: iodesc - character(len=64) :: filename - real(r8) :: fillval - integer(PIO_OFFSET_KIND), allocatable :: ldof(:) - integer :: dimids(2) - integer :: bnddimid - integer :: bounds(2) - integer :: dimsizes(2) - integer :: ierr - integer :: i, m, lsize - logical :: compute_maxdim - - ! Find an unused filename for this variable - call find_dump_filename(fieldname, filename) - - ! Should we compute max dim sizes or assume they are all the same? - if (present(compute_maxdim_in)) then - compute_maxdim = compute_maxdim_in - else - compute_maxdim = .true. - end if - - if (present(fill_value)) then - fillval = fill_value - else - fillval = -900._r8 - end if - - ! Open the file for writing - call cam_pio_createfile(file, trim(filename)) - - ! Define dimensions - if (compute_maxdim) then - call MPI_allreduce((dim1e - dim1b + 1), dimsizes(1), 1, MPI_integer, & - mpi_max, mpicom, ierr) - else - dimsizes(1) = dim1e - dim1b + 1 - end if - dimsizes(2) = npes - do i = 1, size(dimids, 1) - write(filename, '(a,i0)') 'dim', i - call cam_pio_def_dim(file, trim(filename), dimsizes(i), dimids(i)) - end do - call cam_pio_def_dim(file, 'bounds', size(bounds, 1), bnddimid) - ! Define the variables - call cam_pio_def_var(file, trim(fieldname), pio_double, dimids, vdesc) - call cam_pio_def_var(file, 'field_bounds', pio_int, & - (/ bnddimid, dimids(size(dimids, 1)) /), bnddesc) - if (present(fill_value)) then - ierr = pio_put_att(file, vdesc, '_FillValue', fill_value) - end if - ierr = pio_enddef(file) - - ! Compute the variable decomposition and write field - lsize = product(dimsizes(1:2)) - allocate(ldof(dim1e - dim1b + 1)) - m = 0 - do i = dim1b, dim1e - m = m + 1 - ldof(m) = (iam * lsize) + (i - dim1b + 1) - end do - call pio_initdecomp(pio_subsystem, PIO_DOUBLE, dimsizes, ldof, iodesc) - call pio_write_darray(file, vdesc, iodesc, field(dim1b:dim1e), & - ierr, fillval) - call pio_freedecomp(file, iodesc) - deallocate(ldof) - ! Compute the bounds decomposition and write field bounds - bounds(1) = dim1b - bounds(2) = dim1e - dimsizes(1) = size(bounds, 1) - dimsizes(2) = npes - allocate(ldof(size(bounds, 1))) - do i = 1, size(bounds, 1) - ldof(i) = (iam * size(bounds, 1)) + i - end do - call pio_initdecomp(pio_subsystem, PIO_INT, dimsizes(1:2), ldof, iodesc) - call pio_write_darray(file, bnddesc, iodesc, bounds, ierr, -900) - call pio_freedecomp(file, iodesc) - deallocate(ldof) - - ! All done - call cam_pio_closefile(file) - end subroutine dump_field_1d_d - subroutine dump_field_2d_d(fieldname, dim1b, dim1e, dim2b, dim2e, field, & compute_maxdim_in, fill_value) use pio, only: file_desc_t, var_desc_t, io_desc_t From 5a7c1764b5ac4425c2b2f3b358cf738fbc65a3a7 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Tue, 9 Jul 2024 06:20:40 -0600 Subject: [PATCH 48/79] Adding missing docstrings. --- tools/generate_input_to_stdnames_update.py | 69 ++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/tools/generate_input_to_stdnames_update.py b/tools/generate_input_to_stdnames_update.py index 541ad514..f0b7c852 100644 --- a/tools/generate_input_to_stdnames_update.py +++ b/tools/generate_input_to_stdnames_update.py @@ -1,3 +1,7 @@ +""" + +""" + import argparse import csv import re @@ -6,6 +10,24 @@ def parse_csv(csv_filepath): + """Returns a dictionary of standard names (keys) to input names from snapshots (set value) + + The current spreadsheet currently uses column 0 as the input name and column 6 as the standard name. + Currently only using 432 lines in the spread sheet that need standard names. + + Ex: + + .. code-block:: + + A1,...,...,...,...,A6,... + B1,...,...,...,...,A6,... + C1,...,...,...,...,C5,... + + -> + + { A6: (A1, B1), C5: (C1) + + """ datamap = defaultdict(set) pattern = re.compile(r"\w+") print(f"Opening {csv_filepath}") @@ -24,6 +46,33 @@ def parse_csv(csv_filepath): def generate_stdname_xml(current_dict, output_filename): + """ + Generates an xml file to be used by a converter script that converts + input names in a snapshot file to standard names. + + For example, + + .. code-block:: + + { A6: (A1, B1), C5: (C1) + + would be converted to: + + .. code-block:: XML + + + + + A1 + B1 + + + + C1 + + + + """ xmltree = BeautifulSoup(features="xml") entries = xmltree.new_tag("entries") @@ -44,6 +93,26 @@ def generate_stdname_xml(current_dict, output_filename): def main(): + """ + Parses a CSV file with a column ordering of + + .. code-block:: + + ,...,...,...,...,,... + + and generates a corresponding xml file of the format + + .. code-block:: XML + + + + input_name + ... + + ... + + + """ parser = argparse.ArgumentParser(description='') parser.add_argument('--csv-file', type=str, default='CCPP Standard Names - Sheet1.csv', help='') parser.add_argument('--current-map', type=str, default='stdnames_to_inputnames_dictionary.xml', help='') From 2e4b42e0af13f79f24886dfaa200868f4248cdb2 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 14:18:30 -0600 Subject: [PATCH 49/79] python clean-up --- cime_config/hist_config.py | 239 +++++++++++++++++++------------------ 1 file changed, 122 insertions(+), 117 deletions(-) diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index 8cef329e..f9cf15e8 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -5,7 +5,6 @@ """ # Python library imports -from collections import OrderedDict import logging import os import re @@ -62,7 +61,7 @@ class HistoryConfigError(ValueError): def __init__(self, message): """Initialize this exception""" logging.shutdown() - super(HistoryConfigError, self).__init__(message) + super().__init__(message) ############################################################################## def blank_config_line(line): @@ -91,7 +90,7 @@ def _is_integer(entry): ival = int(str(entry).strip()) except ValueError: ival = None - errmsg = "{} is not an integer".format(entry.strip()) + errmsg = f"{entry.strip()} is not an integer" # end try # end if return ival, errmsg @@ -132,7 +131,7 @@ def _list_of_idents(entry, sep=','): else: errmsg = "" # end if - errmsg += "'{}' is not a valid identifier".format(sample) + errmsg += f"'{sample}' is not a valid identifier" # end if # end for if errmsg: @@ -171,7 +170,7 @@ def _is_mult_period(entry): tokens = [x.strip() for x in str(entry).split('*')] errmsg = None else: - tokens = list() + tokens = [] errmsg = "a frequency ([*]period) is required" # end if num_tokens = len(tokens) @@ -194,7 +193,7 @@ def _is_mult_period(entry): else: good_entry = None time_periods = ", ".join(_TIME_PERIODS) - errmsg = "period must be one of {}".format(time_periods) + errmsg = f"period must be one of {time_periods}" # end if # end if return good_entry, errmsg @@ -221,7 +220,7 @@ def _is_prec_str(entry): if ustr not in _OUT_PRECS: ustr = None out_precs = ", ".join(_OUT_PRECS) - errmsg = "precision must be one of {}".format(out_precs) + errmsg = f"precision must be one of {out_precs}" # end if return ustr, errmsg @@ -251,12 +250,61 @@ def _is_logical(entry): possible_values = ['true','t','.true.','false','f','.false.'] errmsg = None if fval.lower() not in possible_values: - fval = None - out_values = ", ".join(possible_values) - errmsg = "hist_write_nstep0 must be one of {}".format(out_values) + fval = None + out_values = ", ".join(possible_values) + errmsg = f"hist_write_nstep0 must be one of {out_values}" # end if return fval, errmsg +############################################################################## +def _parse_hist_config_line(line, no_command_ok=False): +############################################################################## + """Parse if it is a valid history config command line. + Parse the history configuration command found in . + Return three arguments: + The history config command + A tuple with the command value and command unit number (or None) + An error message if one was generated during parsing or None if no + error was found. + If is not recognized as a valid history config command line, and + is True, then None is returned as the entry and the + error message. + If is not recognized as a valid history config command line, and + is False, then None is returned as the entry and an + error message is returned. + >>> _parse_hist_config_line("hist_add_avg_fields: T, U, V, PS") + ('hist_add_avg_fields', (['T', 'U', 'V', 'PS'], None), None) + >>> _parse_hist_config_line("hist_add_inst_fields;h2: T, U, V, PS") + ('hist_add_inst_fields', (['T', 'U', 'V', 'PS'], 'h2'), None) + >>> _parse_hist_config_line("hist_add_avg_fields;h5: foo, bar") + ('hist_add_avg_fields', (['foo', 'bar'], 'h5'), None) + >>> _parse_hist_config_line("use_topo_file = .false.") + ('use_topo_file', None, "Invalid history config line, 'use_topo_file = .false.'") + >>> _parse_hist_config_line("use_topo_file = .false.", no_command_ok=True) + ('use_topo_file', None, None) + """ + # Find the possible history configuration command for . + sline = line.strip() + cmd = HistConfigEntry.find_command(sline) + if cmd in _HIST_CONFIG_ENTRY_OBJS: + # We have a history configuration command, parse it + hconfig = _HIST_CONFIG_ENTRY_OBJS[cmd] + entry, errmsg = hconfig.get_entry(sline) + elif no_command_ok: + entry = None + errmsg = None + else: + # Comments and blank lines are okay + entry = None + if (not sline) or (sline[0] == '!'): + cmd = None + errmsg = None + else: + errmsg = f"Invalid history config line, '{sline}'" + # end if + # end if + return cmd, entry, errmsg + ############################################################################## class HistFieldList(): ############################################################################## @@ -277,7 +325,7 @@ def __init__(self, volume, list_type, list_desc): self.__volume = volume self.__type = list_type self.__desc = list_desc - self.__field_names = list() + self.__field_names = [] self.__max_namelen = 0 def _add_item(self, item, comp_lists, pobj, logger): @@ -291,11 +339,11 @@ def _add_item(self, item, comp_lists, pobj, logger): iadd = str(item).strip() do_add = True for hflist in comp_lists: - if iadd in hflist.__field_names and self.desc == hflist.desc: + if iadd in hflist.field_names and self.desc == hflist.desc: # Field is a duplicate (both the name and the type match) do_add = False ctx = context_string(pobj) - logger.warning(hflist.__dup_field_msg.format(iadd, hflist.desc, + logger.warning(__dup_field_msg.format(iadd, hflist.desc, self.volume, ctx)) break # end if @@ -318,7 +366,6 @@ def add_fields(self, items, comp_lists, pobj, logger): added if it is found in any of those objects. is the ParseObject source of """ - context = context_string(pobj) if isinstance(items, list): do_add = True for item in items: @@ -384,7 +431,7 @@ def output_nl_fieldlist(self, outfile, field_varname): # end while # Output this line comma = "," if fld_end < num_fields - 1 else "" - quotelist = ["'{}{}'".format(x, ' '*(self.max_len - len(x))) + quotelist = [f"'{x}{' '*(self.max_len - len(x))}'" for x in self.__field_names[fld_beg:fld_end+1]] outfile.write(f"{lhs}{', '.join(quotelist)}{comma}\n") lhs = blank_lhs @@ -412,11 +459,10 @@ def max_len(self): """ return self.__max_namelen - def __str__(self): - """Return a string representing this HistFieldList object and its - contents. - """ - return "{}: [{}]".format(self.name, ", ".join(self.__field_names)) + @property + def field_names(self): + """Return the list of field names""" + return self.__field_names ############################################################################## ### @@ -489,8 +535,7 @@ def get_entry(self, line): # end if else: entry = None - errmsg = "Invalid {} history config line, '{}'".format(self.name, - line.strip()) + errmsg = f"Invalid {self.name} history config line, '{line.strip()}'" # end if return entry, errmsg @@ -565,14 +610,13 @@ def __init__(self, volume): self.__file_type = self.__HIST_FILE self.__filename_spec = _DEFAULT_HISTORY_SPEC self.__restart_fname_spec = _DEFAULT_RESTART_HIST_SPEC - self.__fname_spec_set = False self.__restart_fname_spec_set = False - self.__collect_patch_output = False - self.__interp_out = False - self.__interp_nlat = 0 - self.__interp_nlon = 0 - self.__interp_grid = self.__UNSET_C - self.__interp_type = self.__UNSET_C +# self.__collect_patch_output = False +# self.__interp_out = False +# self.__interp_nlat = 0 +# self.__interp_nlon = 0 +# self.__interp_grid = self.__UNSET_C +# self.__interp_type = self.__UNSET_C self.__write_nstep0 = ".false." def add_inst_fields(self, fields, pobj, logger): @@ -651,7 +695,7 @@ def set_precision(self, prec, pobj, logger): self.__precision_set = True if logger.getEffectiveLevel() <= logging.DEBUG: ctx = context_string(pobj) - logger.debug("Setting precision to '{}'{}".format(prec, ctx)) + logger.debug(f"Setting precision to '{prec}'{ctx}") # end if return True # end if @@ -680,8 +724,7 @@ def set_max_frames(self, nframes, pobj, logger): self.__max_frames_set = True if logger.getEffectiveLevel() <= logging.DEBUG: ctx = context_string(pobj) - logger.debug("Setting max frames to '{}'{}".format(nframes, - ctx)) + logger.debug(f"Setting max frames to '{nframes}'{ctx}") # end if else: emsg = "Attempt to set max frames to '{}', must be positive integer" @@ -693,21 +736,30 @@ def set_write_nstep0(self, write_nstep0, pobj, logger): """Modify the write_nstep0 property of this HistoryVolConfig object. Return True if valid""" true_values = ["true", "t", ".true."] + false_values = ["false", "f", ".false."] + nstep0_ok = True if write_nstep0.lower() in true_values: - self.__write_nstep0 = ".true." + self.__write_nstep0 = ".true." + elif write_nstep0.lower() in false_values: + self.__write_nstep0 = ".false." else: - self.__write_nstep0 = ".false." + nstep0_ok = False + emsg = "Attempt to set write_nstep0 to '{}', must be true or false" + pobj.add_syntax_err(emsg.format(write_nstep0)) # end if - return True + if nstep0_ok and logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting write_nstep0 to '{self.__write_nstep0}'{ctx}") + # end if + return nstep0_ok def outfreq_str(self): """Return the output_frequency for this HistoryVolConfig object as a string""" if isinstance(self.__output_freq, tuple): - return "{}*{}".format(self.__output_freq[0], self.__output_freq[1]) - else: - return str(self.__output_freq) + return f"{self.__output_freq[0]}*{self.__output_freq[1]}" # end if + return str(self.__output_freq) @property def output_frequency(self): @@ -724,6 +776,10 @@ def set_output_frequency(self, ofreq, pobj, logger): (ofreq[0] > 0) and (ofreq[1].strip() in _TIME_PERIODS)): self.__output_freq = ofreq + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting output_frequency to '{ofreq}'{ctx}") + # end if return True # end if emsg = "Attempt to set unrecognized output_frequency, '{}'" @@ -751,7 +807,7 @@ def set_file_type(self, ftype, pobj, logger): # end if if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): ctx = context_string(pobj) - logger.debug("Setting file type to '{}'{}".format(ftype, ctx)) + logger.debug(f"Setting file type to '{ftype}'{ctx}") # end if return True @@ -766,8 +822,7 @@ def set_filename_spec(self, fnspec, pobj=None, logger=None): for if possible (i.e., if contains a '%u'). Note that it is an error to try and set this twice. """ - self.__filename_spec = ftype - self.__fname_spec_set = True + self.__filename_spec = fnspec if not self.__restart_fname_spec_set: if '%u' in self.__filename_spec: self.__restart_fname_spec = self.__filename_spec.replace("%u", @@ -776,7 +831,7 @@ def set_filename_spec(self, fnspec, pobj=None, logger=None): # end if if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): ctx = context_string(pobj) - logger.debug("Setting filename spec to '{}'{}".format(fnspec, ctx)) + logger.debug(f"Setting filename spec to '{fnspec}'{ctx}") # end if return True @@ -799,8 +854,7 @@ def set_restart_fname_spec(self, rfnspec=None, pobj=None, logger=None): self.__restart_fname_spec_set = True if (logger is not None) and (logger.getEffectiveLevel() <= logging.DEBUG): ctx = context_string(pobj) - logger.debug("Setting restart filename spec to '{}'{}".format(fnspec, - ctx)) + logger.debug(f"Setting restart filename spec to '{fnspec}'{ctx}") # end if return True @@ -895,56 +949,9 @@ def __init__(self, filename=None, logger=None): if not logger: raise ParseInternalError("Logger required to parse file") # end if - ret = self.parse_hist_config_file(filename, logger) + self.parse_hist_config_file(filename, logger) # end if (no else, just leave empty dictionary) - def parse_hist_config_line(self, line, no_command_ok=False): - """Parse if it is a valid history config command line. - Parse the history configuration command found in . - Return three arguments: - The history config command - A tuple with the command value and command unit number (or None) - An error message if one was generated during parsing or None if no - error was found. - If is not recognized as a valid history config command line, and - is True, then None is returned as the entry and the - error message. - If is not recognized as a valid history config command line, and - is False, then None is returned as the entry and an - error message is returned. - >>> HistoryConfig().parse_hist_config_line("hist_add_avg_fields: T, U, V, PS") - ('hist_add_avg_fields', (['T', 'U', 'V', 'PS'], None), None) - >>> HistoryConfig().parse_hist_config_line("hist_add_inst_fields;h2: T, U, V, PS") - ('hist_add_inst_fields', (['T', 'U', 'V', 'PS'], 'h2'), None) - >>> HistoryConfig().parse_hist_config_line("hist_add_avg_fields;h5: foo, bar") - ('hist_add_avg_fields', (['foo', 'bar'], 'h5'), None) - >>> HistoryConfig().parse_hist_config_line("use_topo_file = .false.") - ('use_topo_file', None, "Invalid history config line, 'use_topo_file = .false.'") - >>> HistoryConfig().parse_hist_config_line("use_topo_file = .false.", no_command_ok=True) - ('use_topo_file', None, None) - """ - # Find the possible history configuration command for . - sline = line.strip() - cmd = HistConfigEntry.find_command(sline) - if cmd in _HIST_CONFIG_ENTRY_OBJS: - # We have a history configuration command, parse it - hconfig = _HIST_CONFIG_ENTRY_OBJS[cmd] - entry, errmsg = hconfig.get_entry(sline) - elif no_command_ok: - entry = None - errmsg = None - else: - # Comments and blank lines are okay - entry = None - if (not sline) or (sline[0] == '!'): - cmd = None - errmsg = None - else: - errmsg = "Invalid history config line, '{}'".format(sline) - # end if - # end if - return cmd, entry, errmsg - def parse_hist_config_file(self, filename, logger, volume=None): """Parse the history configuration commands from and store the resulting configuration information. @@ -960,7 +967,7 @@ def parse_hist_config_file(self, filename, logger, volume=None): # Store directory information for relative paths file_dir = os.path.dirname(os.path.abspath(filename)) no_comm_ok = volume is None # Can have mixed lines for user_nl_cam - with open(filename, "r") as cfile: + with open(filename, "r", encoding="UTF-8") as cfile: clines = cfile.readlines() for index, line in enumerate(clines): clines[index] = line.strip() @@ -968,9 +975,9 @@ def parse_hist_config_file(self, filename, logger, volume=None): # end with # create a parse object and context for this file pobj = ParseObject(filename, clines) - curr_line, linenum = pobj.curr_line() + curr_line, _ = pobj.curr_line() while pobj.valid_line(): - args = self.parse_hist_config_line(curr_line, + args = _parse_hist_config_line(curr_line, no_command_ok=no_comm_ok) cmd, entry, errmsg = args hist_config = None @@ -981,15 +988,15 @@ def parse_hist_config_file(self, filename, logger, volume=None): # Find a hist_config if volume and fnum and (volume != fnum): # This is an error - errmsg = "Volume information not allowed in {}," - errmsg += "\n{}".format(curr_line) - pobj.add_syntax_err(errmsg.format(filename)) + errmsg = f"Volume information not allowed in {filename}," + errmsg += f"\n{curr_line}" + pobj.add_syntax_err(errmsg) elif volume: if volume not in self: # Someone made a boo boo ctx = context_string(pobj) - emsg = "volume, '{}', not in configs{}" - raise ParseInternalError(emsg.format(volume, ctx)) + emsg = f"volume, '{volume}', not in configs{ctx}" + raise ParseInternalError(emsg) # end if hist_config = self[volume] fnum = volume @@ -1001,16 +1008,16 @@ def parse_hist_config_file(self, filename, logger, volume=None): self[fnum] = hist_config # end if else: - errmsg = "Volume information required in {}," - errmsg += "\n{}".format(curr_line) - pobj.add_syntax_err(errmsg.format(filename)) + errmsg = f"Volume information required in {filename}," + errmsg += f"\n{curr_line}" + pobj.add_syntax_err(errmsg) # end if else: if (not no_comm_ok) and (not blank_config_line(curr_line)): # Something has gone wrong. ctx = context_string(pobj) - emsg = "Bad line but no error{}" - raise ParseInternalError(emsg.format(ctx)) + emsg = f"Bad line but no error{ctx}" + raise ParseInternalError(emsg) # end if # end if if hist_config: @@ -1035,18 +1042,17 @@ def parse_hist_config_file(self, filename, logger, volume=None): # end if else: hconf_entry = _HIST_CONFIG_ENTRY_OBJS[cmd] - entry_ok = hconf_entry.process_data(hist_config, cmd_val, + hconf_entry.process_data(hist_config, cmd_val, pobj, logger) # end if # end if (no else, any error was already generated) # Done with this line, move on - curr_line, linenum = pobj.next_line() + curr_line, _ = pobj.next_line() # end while if pobj.error_message: # Time to dump out error messages raise HistoryConfigError(pobj.error_message) # end if - return True def max_num_fields(self, fld_type): """Return the maximum number of fields for on any history @@ -1054,24 +1060,23 @@ def max_num_fields(self, fld_type): nums_flds = [x.num_fields(fld_type) for x in self.values()] if len(nums_flds) == 0: return 0 - else: - return max(nums_flds) # end if + return max(nums_flds) def output_class_namelist(self, ofile): """Write the master class namelist (e.g., num fields)""" - ofile.write("\n&hist_config_arrays_nl\n"); + ofile.write("\n&hist_config_arrays_nl\n") num_fields = self.max_num_fields('inst') - ofile.write(" hist_num_inst_fields = {}\n".format(num_fields)); + ofile.write(f" hist_num_inst_fields = {num_fields}\n") num_fields = self.max_num_fields('avg') - ofile.write(" hist_num_avg_fields = {}\n".format(num_fields)); + ofile.write(f" hist_num_avg_fields = {num_fields}\n") num_fields = self.max_num_fields('min') - ofile.write(" hist_num_min_fields = {}\n".format(num_fields)); + ofile.write(f" hist_num_min_fields = {num_fields}\n") num_fields = self.max_num_fields('max') - ofile.write(" hist_num_max_fields = {}\n".format(num_fields)); + ofile.write(f" hist_num_max_fields = {num_fields}\n") num_fields = self.max_num_fields('var') - ofile.write(" hist_num_var_fields = {}\n".format(num_fields)); - ofile.write("/\n"); + ofile.write(f" hist_num_var_fields = {num_fields}\n") + ofile.write("/\n") ############################################################################## #IGNORE EVERYTHING BELOW HERE UNLESS RUNNING TESTS ON CAM_CONFIG! From 228fc520ae3e8e33e4422e8f3cd6642df6edfb34 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 14:26:15 -0600 Subject: [PATCH 50/79] python cleanup for test_hist_config --- test/unit/test_hist_config.py | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/test/unit/test_hist_config.py b/test/unit/test_hist_config.py index 5f4856ec..9b701439 100644 --- a/test/unit/test_hist_config.py +++ b/test/unit/test_hist_config.py @@ -16,10 +16,8 @@ import filecmp import logging import os -import shutil import sys import unittest -import xml.etree.ElementTree as ET __TEST_DIR = os.path.dirname(os.path.abspath(__file__)) _CAM_ROOT = os.path.abspath(os.path.join(__TEST_DIR, os.pardir, os.pardir)) @@ -32,9 +30,9 @@ # Find python version PY3 = sys.version_info[0] > 2 if PY3: - __FILE_OPEN = (lambda x: open(x, 'r', encoding='utf-8')) + def __FILE_OPEN(x): return open(x, 'r', encoding='utf-8') else: - __FILE_OPEN = (lambda x: open(x, 'r')) + def __FILE_OPEN(x): return open(x, 'r') # End if if not os.path.exists(__CIME_CONFIG_DIR): @@ -101,7 +99,7 @@ def test_flat_user_nl_cam(self): amsg = "Test failure: no HistConfig object created" self.assertTrue(isinstance(hist_configs, HistoryConfig), msg=amsg) clen = len(hist_configs) - amsg = "Test failure: Found {} history files, expected 3".format(clen) + amsg = f"Test failure: Found {clen} history files, expected 3" self.assertEqual(clen, 3, msg=amsg) # Check properties of created config objects self.assertTrue('h1' in hist_configs, msg="'h1' not in hist_configs") @@ -118,10 +116,10 @@ def test_flat_user_nl_cam(self): # end for # end with # Make sure each output file was created - amsg = "{} does not exist".format(out_source) + amsg = f"{out_source} does not exist" self.assertTrue(os.path.exists(out_source), msg=amsg) # Make sure the output file is correct - amsg = "{} does not match {}".format(out_source, out_test) + amsg = f"{out_source} does not match {out_test}" self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), msg=amsg) @@ -141,7 +139,7 @@ def test_multi_user_nl_cam(self): amsg = "Test failure: no HistConfig object created" self.assertTrue(isinstance(hist_configs, HistoryConfig), msg=amsg) clen = len(hist_configs) - amsg = "Test failure: Found {} history files, expected 2".format(clen) + amsg = f"Test failure: Found {clen} history files, expected 2" self.assertEqual(clen, 2, msg=amsg) # Check properties of created config objects self.assertTrue('h0' in hist_configs, msg="'h0' not in hist_configs") @@ -158,10 +156,10 @@ def test_multi_user_nl_cam(self): # end for # end with # Make sure each output file was created - amsg = "{} does not exist".format(out_source) + amsg = f"{out_source} does not exist" self.assertTrue(os.path.exists(out_source), msg=amsg) # Make sure the output file is correct - amsg = "{} does not match {}".format(out_source, out_test) + amsg = f"{out_source} does not match {out_test}" self.assertTrue(filecmp.cmp(out_test, out_source, shallow=False), msg=amsg) From 14dcf39fc89d598e0c5a1443142a857642b584a1 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 14:28:35 -0600 Subject: [PATCH 51/79] remove unnecessary python version check --- test/unit/test_hist_config.py | 8 -------- 1 file changed, 8 deletions(-) diff --git a/test/unit/test_hist_config.py b/test/unit/test_hist_config.py index 9b701439..a43f2e50 100644 --- a/test/unit/test_hist_config.py +++ b/test/unit/test_hist_config.py @@ -27,14 +27,6 @@ _TMP_DIR = os.path.join(__TEST_DIR, "tmp") _LOGGER = logging.getLogger(__name__) -# Find python version -PY3 = sys.version_info[0] > 2 -if PY3: - def __FILE_OPEN(x): return open(x, 'r', encoding='utf-8') -else: - def __FILE_OPEN(x): return open(x, 'r') -# End if - if not os.path.exists(__CIME_CONFIG_DIR): raise ImportError("Cannot find /cime_config") From d394b9209aef409d3f8456e3e3a74784366c863b Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 14:43:41 -0600 Subject: [PATCH 52/79] handle volume configured with no fields --- cime_config/buildnml | 2 +- cime_config/hist_config.py | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 9d576cab..ddff8621 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -395,7 +395,7 @@ def buildnml(case, caseroot, compname): with open(namelist_file, 'a', encoding='utf-8') as nl_file: hist_configs.output_class_namelist(nl_file) for key in sorted(hist_configs.keys()): - hist_configs[key].output_config_namelist(nl_file) + hist_configs[key].output_config_namelist(nl_file, logger=_LOGGER) # end for # end with diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index f9cf15e8..f00b53c0 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -871,14 +871,22 @@ def num_fields(self, fld_type): num_flds = self.__max_fields.num_fields() elif fld_type == 'var': num_flds = self.__var_fields.num_fields() + elif fld_type == 'all': + num_flds = self.__avg_fields.num_fields() + self.__inst_fields.num_fields() + \ + self.__min_fields.num_fields() + self.__max_fields.num_fields() + \ + self.__var_fields.num_fields() else: raise ParseInternalError("Unknown fld_type, '{}'".format(fld_type)) # end if return num_flds - def output_config_namelist(self, outfile): + def output_config_namelist(self, outfile, logger): """Write the fortran namelist object for this HistoryVolConfig object""" + if self.num_fields('all') == 0: + logger.warning(f"WARNING: Volume '{self.volume}' has no fields; skipping") + return + # end if outfile.write("\n&hist_file_config_nl\n") outfile.write(f" hist_volume = '{self.volume}'\n") self.__inst_fields.output_nl_fieldlist(outfile, "hist_inst_fields") From d87e41f0babd1672bae9818f7ea92c353a5cf350 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 14:45:53 -0600 Subject: [PATCH 53/79] fix hist_config test --- test/unit/test_hist_config.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/unit/test_hist_config.py b/test/unit/test_hist_config.py index a43f2e50..3552fdcc 100644 --- a/test/unit/test_hist_config.py +++ b/test/unit/test_hist_config.py @@ -104,7 +104,7 @@ def test_flat_user_nl_cam(self): with open(out_source, 'w', encoding='utf-8') as nl_file: hist_configs.output_class_namelist(nl_file) for key in sorted(hist_configs.keys()): - hist_configs[key].output_config_namelist(nl_file) + hist_configs[key].output_config_namelist(nl_file, logger=_LOGGER) # end for # end with # Make sure each output file was created @@ -144,7 +144,7 @@ def test_multi_user_nl_cam(self): with open(out_source, 'w', encoding='utf-8') as nl_file: hist_configs.output_class_namelist(nl_file) for key in sorted(hist_configs.keys()): - hist_configs[key].output_config_namelist(nl_file) + hist_configs[key].output_config_namelist(nl_file, logger=_LOGGER) # end for # end with # Make sure each output file was created From 1a58f1507dc569e3498bf8514590b7b3767e7844 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 15:35:01 -0600 Subject: [PATCH 54/79] fix write_nstep0 logic --- src/control/cam_comp.F90 | 4 ++-- src/history/cam_history.F90 | 8 ++++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index f2dfeeb1..5c93b463 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -445,10 +445,10 @@ subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check) logical, intent(in) :: rstwr ! write restart file logical, intent(in) :: nlend ! this is final timestep !Flag for whether a snapshot (ncdata) check should be run or not - ! - flag is true if this is not the last step + ! - flag is true if this is not the first or last step logical, intent(in) :: do_ncdata_check - if (do_ncdata_check) then + if (do_ncdata_check .or. get_nstep() == 0) then call physics_history_out() call history_write_files() ! peverwhee - todo: handle restarts diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index 8ab25c5a..af89b5ca 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -185,8 +185,12 @@ subroutine history_write_files() end if end select write_nstep0 = hist_configs(file_idx)%do_write_nstep0() - if (write_nstep0 .and. nstep == 0) then - write_history = .true. + if (nstep == 0) then + if (write_nstep0) then + write_history = .true. + else + write_history = .false. + end if end if if (.not. write_history) then ! Don't write this volume! From 67b0b216e8b1ae5149454b18e4011e850565b8e3 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 9 Jul 2024 19:04:18 -0600 Subject: [PATCH 55/79] add missing mpi_broadcast --- src/history/cam_hist_file.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 5142cb1f..1a5b7b3f 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -1835,6 +1835,8 @@ subroutine read_namelist_entry(unitn, hfile_config, hist_inst_fields, & masterprocid, mpicom, ierr) call MPI_Bcast(hist_collect_patch_output, 1, MPI_LOGICAL, & masterprocid, mpicom, ierr) + call MPI_Bcast(hist_write_nstep0, 1, MPI_LOGICAL, & + masterprocid, mpicom, ierr) call MPI_Bcast(file_type, 1, MPI_INTEGER, masterprocid, mpicom, ierr) call MPI_Bcast(hist_interp_grid, flen, MPI_CHARACTER, & masterprocid, mpicom, ierr) From 7e8562b476d53acfbbae7ef5431fe182eaf28be1 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Fri, 12 Jul 2024 14:39:42 -0600 Subject: [PATCH 56/79] Addressing review comments. --- Externals_CAM.cfg | 4 ++-- src/dynamics/utils/hycoef.F90 | 12 ++++++------ tools/generate_input_to_stdnames_update.py | 3 --- tools/inputnames_to_stdnames.py | 2 +- 4 files changed, 9 insertions(+), 12 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 4c1361ad..3319c34f 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,8 +1,8 @@ [ccpp-framework] local_path = ccpp_framework protocol = git -repo_url = https://github.com/peverwhee/ccpp-framework -tag = CPF_0.2.057 +repo_url = https://github.com/NCAR/ccpp-framework +tag = 2024-07-11-dev required = True [mpas] diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 33ee5a2f..1ca3e6e3 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -412,7 +412,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer', lev_dimid) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading lev') + call endrun(routine//': ERROR: unable to find lev dimension in ncdata or restart file.') end if end if ierr = PIO_Inq_dimlen(File, lev_dimid, flev) @@ -425,7 +425,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = PIO_Inq_DimID(File, 'reference_pressure_in_atmosphere_layer_at_interfaces', lev_dimid) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading ilev') + call endrun(routine//': ERROR: unable to find ilev dimension in ncdata or restart file') end if end if ierr = PIO_Inq_dimlen(File, lev_dimid, filev) @@ -438,7 +438,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient_at_interfaces', hyai_desc) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading hyai') + call endrun(routine//': ERROR: unable to find hyai variable in ncdata or restart file') end if end if @@ -446,7 +446,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_a_coefficient', hyam_desc) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading hyam') + call endrun(routine//': ERROR: unable to find hyam variable in ncdata or restart file') end if end if @@ -454,7 +454,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient_at_interfaces', hybi_desc) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading hybi') + call endrun(routine//': ERROR: unable to find hybi variable in ncdata or restart file') end if end if @@ -462,7 +462,7 @@ subroutine hycoef_read(File) if (ierr /= PIO_NOERR) then ierr = pio_inq_varid(File, 'sigma_pressure_hybrid_coordinate_b_coefficient', hybm_desc) if (ierr /= PIO_NOERR) then - call endrun(routine//': reading hybm') + call endrun(routine//': ERROR: unable to find hybm variable in ncdata or restart file') end if end if diff --git a/tools/generate_input_to_stdnames_update.py b/tools/generate_input_to_stdnames_update.py index f0b7c852..12967d42 100644 --- a/tools/generate_input_to_stdnames_update.py +++ b/tools/generate_input_to_stdnames_update.py @@ -38,8 +38,6 @@ def parse_csv(csv_filepath): standardname_match = pattern.fullmatch(row[5].split(" ")[0]) if csvdata.line_num < 432 and standardname_match and inputname and "Skipping" not in row[5] and "CCPP" not in row[5]: print(f"Adding {inputname} under {standardname_match.string}") - # if standardname_match.string in datamap: - # raise Exception(f"Found duplicate standard name {standardname_match.string} on line {csvdata.line_num}") datamap[standardname_match.string].add(inputname) return datamap @@ -115,7 +113,6 @@ def main(): """ parser = argparse.ArgumentParser(description='') parser.add_argument('--csv-file', type=str, default='CCPP Standard Names - Sheet1.csv', help='') - parser.add_argument('--current-map', type=str, default='stdnames_to_inputnames_dictionary.xml', help='') parser.add_argument('--output-map', type=str, default='stdnames_to_inputnames_dictionary_new.xml', help='') args = parser.parse_args() diff --git a/tools/inputnames_to_stdnames.py b/tools/inputnames_to_stdnames.py index 8515a36f..84edc3dc 100644 --- a/tools/inputnames_to_stdnames.py +++ b/tools/inputnames_to_stdnames.py @@ -100,7 +100,7 @@ def parse_command_line(arguments, description): metavar='stdname file', help="Full path to the standard names dictionary (e.g. stdnames_to_inputnames_dictionary.xml)") parser.add_argument('--tphys', type=str, required=True, - metavar='tphysac or tphybs group - REQUIRED', + metavar='tphysac or tphysbc group - REQUIRED', help='Group to convert to stdandard names') pargs = parser.parse_args(arguments) return pargs From dbdbbadfc373fe110717790c15133d0842e30e34 Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 15 Jul 2024 10:40:10 -0600 Subject: [PATCH 57/79] Addressing review comments and adding error checking to PIO calls. --- src/dynamics/utils/hycoef.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 1ca3e6e3..e5a21758 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -467,9 +467,21 @@ subroutine hycoef_read(File) end if ierr = pio_get_var(File, hyai_desc, hyai) + if (ierr /= PIO_NOERR) then + call endrun(routine//': ERROR: Unable to get hyai variable in ncdata or restart file.') + end if ierr = pio_get_var(File, hybi_desc, hybi) + if (ierr /= PIO_NOERR) then + call endrun(routine//': ERROR: Unable to get hybi variable in ncdata or restart file.') + end if ierr = pio_get_var(File, hyam_desc, hyam) + if (ierr /= PIO_NOERR) then + call endrun(routine//': ERROR: Unable to get hyam variable in ncdata or restart file.') + end if ierr = pio_get_var(File, hybm_desc, hybm) + if (ierr /= PIO_NOERR) then + call endrun(routine//': ERROR: Unable to get hybm variable in ncdata or restart file.') + end if if (masterproc) then write(iulog,*) routine//': read hyai, hybi, hyam, hybm' From 0f673e215338f2ad4c5e30578a6a021fb7b04b2d Mon Sep 17 00:00:00 2001 From: Michael Waxmonsky Date: Mon, 15 Jul 2024 10:50:06 -0600 Subject: [PATCH 58/79] Addressing review comments. Updating tphys variable name to better communicate intention. --- tools/inputnames_to_stdnames.py | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tools/inputnames_to_stdnames.py b/tools/inputnames_to_stdnames.py index 84edc3dc..a78b0f48 100644 --- a/tools/inputnames_to_stdnames.py +++ b/tools/inputnames_to_stdnames.py @@ -18,7 +18,7 @@ def write_new_ncdata_file(input_filename, output_filename, inputname_dict): base_cmd += f' {input_filename}' os.system(base_cmd) -def parse_stdname_file(file_to_parse, tphys): +def parse_stdname_file(file_to_parse, tphys_exclude): """Parse XML standard name dictionary""" with open(file_to_parse, encoding='utf-8') as fh1: try: @@ -35,7 +35,7 @@ def parse_stdname_file(file_to_parse, tphys): for sub_element in entry: if sub_element.tag == "ic_file_input_names": for input_name in sub_element: - if not input_name.text.startswith(tphys): + if not input_name.text.startswith(tphys_exclude): inputname_dict[input_name.text.strip()] = stdname # end if startswith # end for input_name @@ -45,7 +45,7 @@ def parse_stdname_file(file_to_parse, tphys): return inputname_dict -def main(input_file, output_filename, stdname_file, tphys): +def main(input_file, output_filename, stdname_file, tphys_exclude): """Parse standard name dictionary and then replace input name variables with stdnames""" if not os.path.isfile(input_file): print(f"Input file {input_file} does not exist") @@ -76,7 +76,7 @@ def main(input_file, output_filename, stdname_file, tphys): #end if os.path.isdir(output_dir) #end if len(output_dir.strip())) == 0 # Parse the standard name dictionary - inputname_dict = parse_stdname_file(stdname_file, tphys) + inputname_dict = parse_stdname_file(stdname_file, tphys_exclude) if not inputname_dict: print(f"Standard name dictionary {stdname_file} empty or not parse-able") return 6 @@ -99,12 +99,12 @@ def parse_command_line(arguments, description): parser.add_argument("--stdnames", type=str, required=True, metavar='stdname file', help="Full path to the standard names dictionary (e.g. stdnames_to_inputnames_dictionary.xml)") - parser.add_argument('--tphys', type=str, required=True, + parser.add_argument('--tphys-exclude', type=str, required=True, metavar='tphysac or tphysbc group - REQUIRED', - help='Group to convert to stdandard names') + help='Group to exclude when converting variable names to stdandard names') pargs = parser.parse_args(arguments) return pargs if __name__ == "__main__": ARGS = parse_command_line(sys.argv[1:], __doc__) - sys.exit(main(ARGS.input, ARGS.output, ARGS.stdnames, ARGS.tphys)) + sys.exit(main(ARGS.input, ARGS.output, ARGS.stdnames, ARGS.tphys_exclude)) From 9bd89cbf06ccb19864ea03a39dd9bf7d30a0beab Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Mon, 22 Jul 2024 16:23:57 -0600 Subject: [PATCH 59/79] use diagnostic schemes instead of python-generated history --- Externals_CAM.cfg | 5 +- cime_config/buildlib | 3 +- cime_config/cam_autogen.py | 71 +-- cime_config/cam_build_cache.py | 54 +- cime_config/cam_config.py | 16 +- src/control/cam_comp.F90 | 4 - src/data/generate_registry_data.py | 83 +-- src/data/registry.xml | 23 +- src/data/write_hist_file.py | 595 ------------------ src/physics/utils/physics_data.F90 | 2 + test/run_unit_tests.sh | 2 - .../build_cache_files/example_build_cache.xml | 1 - .../update_ccpp_build_cache.xml | 1 - .../update_init_gen_build_cache.xml | 1 - .../update_reg_build_cache.xml | 2 - .../write_hist_file/physics_history_ddt.F90 | 74 --- .../write_hist_file/physics_history_ddt2.F90 | 74 --- .../physics_history_ddt_array.F90 | 74 --- .../physics_history_no_req_var.F90 | 68 -- .../physics_history_simple.F90 | 87 --- .../simple_build_cache_template.xml | 1 - test/unit/test_build_cache.py | 3 +- test/unit/test_cam_autogen.py | 2 +- test/unit/test_write_hist_file.py | 486 -------------- 24 files changed, 25 insertions(+), 1707 deletions(-) delete mode 100644 src/data/write_hist_file.py delete mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt.F90 delete mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 delete mode 100644 test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 delete mode 100644 test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 delete mode 100644 test/unit/sample_files/write_hist_file/physics_history_simple.F90 delete mode 100644 test/unit/test_write_hist_file.py diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 313f8dd8..2ba5c57a 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -23,8 +23,9 @@ required = True [ncar-physics] local_path = src/physics/ncar_ccpp protocol = git -repo_url = https://github.com/ESCOMP/atmospheric_physics -tag = atmos_phys0_03_000 +repo_url = https://github.com/peverwhee/atmospheric_physics +#tag = atmos_phys0_03_000 +branch = diagnostics required = True [externals_description] diff --git a/cime_config/buildlib b/cime_config/buildlib index 383c3893..214e6182 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -78,7 +78,6 @@ def _build_cam(): dycore = config.get_value('dyn') reg_dir = config.get_value('reg_dir') init_dir = config.get_value('init_dir') - hist_dir = config.get_value('hist_dir') phys_dirs_str = config.get_value('phys_dirs') #Convert the phys_dirs_str into a proper list: @@ -91,7 +90,7 @@ def _build_cam(): filepath_src = os.path.join(caseroot, "Buildconf", "camconf", "Filepath") filepath_dst = os.path.join(bldroot, "Filepath") - paths = [source_mods_dir, reg_dir, init_dir, hist_dir, + paths = [source_mods_dir, reg_dir, init_dir, os.path.join(atm_root, "src", "data"), os.path.join(atm_root, "src", "control"), os.path.join(atm_root, "src", "cpl", diff --git a/cime_config/cam_autogen.py b/cime_config/cam_autogen.py index 03ca500e..0520d602 100644 --- a/cime_config/cam_autogen.py +++ b/cime_config/cam_autogen.py @@ -33,7 +33,6 @@ # Import needed registry and other src/data scripts: from generate_registry_data import gen_registry from write_init_files import write_init_files -from write_hist_file import write_hist_file ############################################################################### @@ -77,8 +76,8 @@ def _find_file(filename, search_dirs): doctests: 1. Check that the function can find a file correctly: - >>> _find_file("Externals.cfg", [_CAM_ROOT_DIR]) == \ - os.path.join(_CAM_ROOT_DIR, "Externals.cfg") + >>> _find_file("README.md", [_CAM_ROOT_DIR]) == \ + os.path.join(_CAM_ROOT_DIR, "README.md") True 2. Check that the function returns None if it can't find a file: @@ -393,7 +392,7 @@ def generate_registry(data_search, build_cache, atm_root, bldroot, gen_fort_indent, source_mods_dir, atm_root, logger=_LOGGER, schema_paths=data_search, error_on_no_validate=True) - retcode, reg_file_list, ic_names, diag_names = retvals + retcode, reg_file_list, ic_names = retvals # Raise error if gen_registry failed: if retcode != 0: emsg = "ERROR:Unable to generate CAM data structures from {}, err = {}" @@ -407,15 +406,14 @@ def generate_registry(data_search, build_cache, atm_root, bldroot, # Save build details in the build cache reg_file_paths = [x.file_path for x in reg_file_list if x.file_path] build_cache.update_registry(gen_reg_file, registry_files, dycore, - reg_file_paths, ic_names, diag_names) + reg_file_paths, ic_names) else: # If we did not run the registry generator, retrieve info from cache reg_file_paths = build_cache.reg_file_list() ic_names = build_cache.ic_names() - diag_names = build_cache.diag_names() # End if - return genreg_dir, do_gen_registry, reg_file_paths, ic_names, diag_names + return genreg_dir, do_gen_registry, reg_file_paths, ic_names ############################################################################### def generate_physics_suites(build_cache, preproc_defs, host_name, @@ -681,65 +679,6 @@ def generate_init_routines(build_cache, bldroot, force_ccpp, force_init, return init_dir -############################################################################### -def generate_history_routines(build_cache, bldroot, force_ccpp, force_hist, - source_mods_dir, gen_fort_indent, - cap_database, diag_names): -############################################################################### - """ - Generate the host model history source code file - (physics_history.F90) using both the registry and the CCPP physics suites - if required (new case or changes to registry or CCPP source(s), meta-data, - and/or script). - """ - - #Add new directory to build path: - hist_dir = os.path.join(bldroot, "history") - # Use this for cache check - gen_hist_file = os.path.join(_REG_GEN_DIR, "write_hist_file.py") - - # Figure out if we need to generate new initialization routines: - if os.path.exists(hist_dir): - # Check if registry and / or CCPP suites were modified: - if force_ccpp or force_hist: - do_gen_hist = True - else: - #If not, then check cache to see if actual - #"write_init_files.py" was modified: - do_gen_hist = build_cache.hist_write_mismatch(gen_hist_file) - # end if - else: - #If no directory exists, then one will need - # to create new routines: - os.mkdir(hist_dir) - do_gen_hist = True - # End if - - if do_gen_hist: - - # Run initialization files generator: - # Yes, we are passing a pointer to the find_file function for use - # within write_init_files (so that write_init_files can be the place - # where the source include files are stored). - source_paths = [source_mods_dir, _REG_GEN_DIR] - retmsg = write_hist_file(cap_database, diag_names, hist_dir, - _find_file, source_paths, - gen_fort_indent, _LOGGER) - - #Check that script ran properly: - #----- - if retmsg: - emsg = "ERROR: Unable to generate CAM hist source code, error message is:\n{}" - raise CamAutoGenError(emsg.format(retmsg)) - #----- - - # save build details in the build cache - build_cache.update_hist_gen(gen_hist_file) - # End if - - return hist_dir - - ############# # End of file ############# diff --git a/cime_config/cam_build_cache.py b/cime_config/cam_build_cache.py index 8106fbc9..2bda072e 100644 --- a/cime_config/cam_build_cache.py +++ b/cime_config/cam_build_cache.py @@ -213,7 +213,6 @@ def __init__(self, build_cache): # Set empty values sure to trigger processing self.__gen_reg_file = None self.__gen_init_file = None - self.__gen_hist_file = None self.__registry_files = {} self.__dycore = None self.__sdfs = {} @@ -227,7 +226,6 @@ def __init__(self, build_cache): self.__kind_types = {} self.__reg_gen_files = [] self.__ic_names = {} - self.__diag_names = {} if os.path.exists(build_cache): # Initialize build cache state _, cache = read_xml_file(build_cache) @@ -240,9 +238,6 @@ def __init__(self, build_cache): elif item.tag == 'generate_init_file': new_entry = new_entry_from_xml(item) self.__gen_init_file = new_entry - elif item.tag == 'generate_hist_file': - new_entry = new_entry_from_xml(item) - self.__gen_hist_file = new_entry elif item.tag == 'registry_file': new_entry = new_entry_from_xml(item) self.__registry_files[new_entry.key] = new_entry @@ -257,10 +252,6 @@ def __init__(self, build_cache): # end if itext = clean_xml_text(item) self.__ic_names[stdname].append(itext) - elif item.tag == 'diagnostic_name': - stdname = item.get('standard_name') - flag = item.get('flag') - self.__diag_names[stdname] = (clean_xml_text(item), flag) else: emsg = "ERROR: Unknown registry tag, '{}'" raise ValueError(emsg.format(item.tag)) @@ -322,7 +313,7 @@ def __init__(self, build_cache): # end if def update_registry(self, gen_reg_file, registry_source_files, - dycore, reg_file_list, ic_names, diag_names): + dycore, reg_file_list, ic_names): """Replace the registry cache data with input data """ self.__dycore = dycore @@ -335,10 +326,8 @@ def update_registry(self, gen_reg_file, registry_source_files, # reg_file_list contains the files generated from the registry self.__reg_gen_files = reg_file_list # ic_names are the initial condition variable names from the registry, - # diag_names are the diagnostic variable names from the registry, - # both should already be of type dict: + # and should already be of type dict: self.__ic_names = ic_names - self.__diag_names = diag_names def update_ccpp(self, suite_definition_files, scheme_files, host_files, xml_files, namelist_meta_files, namelist_groups, @@ -378,19 +367,11 @@ def update_ccpp(self, suite_definition_files, scheme_files, host_files, def update_init_gen(self, gen_init_file): """ Replace the init_files writer - (write_init_files.py) cache + (generate_registry_data.py) cache data with input data """ self.__gen_init_file = FileStatus(gen_init_file, 'generate_init_file') - def update_hist_gen(self, gen_hist_file): - """ - Replace the hist_files writer - (write_hist_file.py) cache - data with input data - """ - self.__gen_hist_file = FileStatus(gen_hist_file, 'generate_hist_file') - def write(self): """Write out the current cache state""" new_cache = ET.Element("CAMBuildCache") @@ -399,9 +380,6 @@ def write(self): new_xml_entry(registry, 'generate_init_file', self.__gen_init_file.file_path, self.__gen_init_file.file_hash) - new_xml_entry(registry, 'generate_hist_file', - self.__gen_hist_file.file_path, - self.__gen_hist_file.file_hash) new_xml_entry(registry, 'generate_registry_file', self.__gen_reg_file.file_path, self.__gen_reg_file.file_hash) @@ -422,12 +400,6 @@ def write(self): ic_entry.text = ic_name # end for # end for - for stdname, diag_info in self.__diag_names.items(): - diag_entry = ET.SubElement(registry, 'diagnostic_name') - diag_entry.set('standard_name', stdname) - diag_entry.set('flag', diag_info[1]) - diag_entry.text = diag_info[0] - # end for # CCPP ccpp = ET.SubElement(new_cache, 'CCPP') for sfile in self.__sdfs.values(): @@ -613,22 +585,6 @@ def init_write_mismatch(self, gen_init_file): #Return mismatch logical: return mismatch - def hist_write_mismatch(self, gen_hist_file): - """ - Determine if the hist_file writer (write_hist_file.py) - differs from the data stored in our cache. Return True - if the data differs. - """ - - #Initialize variable: - mismatch = False - - #Check file hash to see if mis-match exists: - mismatch = self.__gen_hist_file.hash_mismatch(gen_hist_file) - - #Return mismatch logical: - return mismatch - def scheme_nl_metadata(self): """Return the stored list of scheme namelist metadata files""" return self.__scheme_nl_metadata @@ -647,9 +603,5 @@ def ic_names(self): """Return a copy of the registry initial conditions dictionary""" return dict(self.__ic_names) - def diag_names(self): - """Return a copy of the registry diagnostic names dictionary""" - return dict(self.__diag_names) - ############# # End of file diff --git a/cime_config/cam_config.py b/cime_config/cam_config.py index eb24e379..80bef16e 100644 --- a/cime_config/cam_config.py +++ b/cime_config/cam_config.py @@ -31,7 +31,7 @@ # Import fortran auto-generation routines: from cam_autogen import generate_registry, generate_physics_suites -from cam_autogen import generate_init_routines, generate_history_routines +from cam_autogen import generate_init_routines ############################################################################### #HELPER FUNCTIONS @@ -838,7 +838,7 @@ def generate_cam_src(self, gen_fort_indent): retvals = generate_registry(data_search, build_cache, self.__atm_root, self.__bldroot, source_mods_dir, dyn, gen_fort_indent) - reg_dir, force_ccpp, reg_files, ic_names, diag_names = retvals + reg_dir, force_ccpp, reg_files, ic_names = retvals #Add registry path to config object: reg_dir_desc = "Location of auto-generated registry code." @@ -877,18 +877,6 @@ def generate_cam_src(self, gen_fort_indent): init_dir_desc = "Location of auto-generated physics initialization code." self.create_config("init_dir", init_dir_desc, init_dir) - #--------------------------------------------------------- - # Create host model variable history routines - #--------------------------------------------------------- - hist_dir = generate_history_routines(build_cache, self.__bldroot, - force_ccpp, force_init, - source_mods_dir, gen_fort_indent, - capgen_db, diag_names) - - #Add registry path to config object: - hist_dir_desc = "Location of auto-generated physics history code." - self.create_config("hist_dir", hist_dir_desc, hist_dir) - #-------------------------------------------------------------- # write out the cache here as we have completed pre-processing #-------------------------------------------------------------- diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index f12bbbd4..cedbea8b 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -26,8 +26,6 @@ module cam_comp use camsrfexch, only: cam_out_t, cam_in_t use physics_types, only: phys_state, phys_tend, dtime_phys - use physics_history, only: physics_history_init - use physics_history, only: physics_history_out use dyn_comp, only: dyn_import_t, dyn_export_t use perf_mod, only: t_barrierf, t_startf, t_stopf @@ -236,7 +234,6 @@ subroutine cam_init(caseid, ctitle, model_doi_url, & ! if (single_column) then ! call scm_intht() ! end if - call physics_history_init() call history_init_files(model_doi_url, caseid, ctitle) end subroutine cam_init @@ -449,7 +446,6 @@ subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check) logical, intent(in) :: do_ncdata_check if (do_ncdata_check .or. get_nstep() == 0) then - call physics_history_out() call history_write_files() ! peverwhee - todo: handle restarts call history_wrap_up(rstwr, nlend) diff --git a/src/data/generate_registry_data.py b/src/data/generate_registry_data.py index 1f530c48..33adc954 100755 --- a/src/data/generate_registry_data.py +++ b/src/data/generate_registry_data.py @@ -155,8 +155,6 @@ def __init__(self, elem_node, local_name, dimensions, known_types, self.__initial_value = '' self.__initial_val_vars = set() self.__ic_names = None - self.__diagnostic_name = None - self.__diagnostic_flag = None self.__elements = [] self.__protected = protected self.__index_name = index_name @@ -188,13 +186,7 @@ def __init__(self, elem_node, local_name, dimensions, known_types, elif attrib.tag == 'ic_file_input_names': #Separate out string into list: self.__ic_names = [x.strip() for x in attrib.text.split(' ') if x] - elif attrib.tag == 'diagnostic': - self.__diagnostic_name = attrib.attrib['name'] - if 'flag' in attrib.attrib: - self.__diagnostic_flag = attrib.attrib['flag'] - else: - self.__diagnostic_flag = 'avg' - # end if + # end if (just ignore other tags) # end for if ((not self.initial_value) and @@ -336,16 +328,6 @@ def dimension_string(self): """Return the dimension_string for this variable""" return '(' + ', '.join(self.dimensions) + ')' - @property - def diagnostic_name(self): - """Return the diagnostic name for this variable""" - return self.__diagnostic_name - - @property - def diagnostic_flag(self): - """Return the diagnostic flag for this variable""" - return self.__diagnostic_flag - @property def long_name(self): """Return the long_name for this variable""" @@ -597,8 +579,6 @@ def __init__(self, var_node, known_types, vdict, logger): pass # picked up in parent elif attrib.tag == 'ic_file_input_names': pass # picked up in parent - elif attrib.tag == 'diagnostic': - pass # picked up in parent else: emsg = "Unknown Variable content, '{}'" raise CCPPError(emsg.format(attrib.tag)) @@ -1694,7 +1674,6 @@ def write_registry_files(registry, dycore, outdir, src_mod, src_root, if file_.generate_code: file_.write_metadata(outdir, logger) file_.write_source(outdir, indent, logger, physconst_vars) -# file_.write_history_source(outdir, indent, logger, physconst_vars) # end if # end for @@ -1754,60 +1733,6 @@ def _create_ic_name_dict(registry): # end for return ic_name_dict -############################################################################### -def _create_diag_name_dict(registry): -############################################################################### - """ Build a dictionary of diagnostic names and flags (key = standard_name) - If this property is ever included in CCPP metadata, this - section can be replaced by accessing the new metadata - property and this routine will no longer be needed. - This function returns a dictionary containing only the variables - from the registry which have the "diagnostic" element. - """ - diag_name_dict = {} - for section in registry: - if section.tag == 'file': - for obj in section: - if obj.tag == 'variable': - for attrib in obj: - if attrib.tag == 'diagnostic': - diags = {} - stdname = obj.get('standard_name') - diag_name = attrib.attrib['name'] - # peverwhee - duplicate check? - if 'flag' in attrib.attrib: - flag = attrib.attrib['flag'] - else: - flag = 'avg' - # end if - diag_name_dict[stdname] = (diag_name, flag) - # end if - # end for - elif obj.tag == 'array': - for subobj in obj: - if subobj.tag == 'element': - for attrib in subobj: - if attrib.tag == 'diagnostic': - diags = {} - stdname = subobj.get('standard_name') - diag_name = attrib.attrib['name'] - # peverwhee - duplicate check? - if 'flag' in attrib.attrib: - flag = attrib.attrib['flag'] - else: - flag = 'avg' - # end if - diag_name_dict[stdname] = (diag_name, flag) - # end if - # end for - # end if - # end for - # end if (ignore other node types) - # end for - # end if (ignore other node types) - # end for - return diag_name_dict - ############################################################################### def gen_registry(registry_file, dycore, outdir, indent, src_mod, src_root, loglevel=None, logger=None, @@ -1877,7 +1802,6 @@ def gen_registry(registry_file, dycore, outdir, indent, retcode = 1 files = None ic_names = None - diag_names = None else: library_name = registry.get('name') emsg = f"Parsing registry, {library_name}" @@ -1887,10 +1811,9 @@ def gen_registry(registry_file, dycore, outdir, indent, src_root, reg_dir, indent, logger) # See comment in _create_ic_name_dict ic_names = _create_ic_name_dict(registry) - diag_names = _create_diag_name_dict(registry) retcode = 0 # Throw exception on error # end if - return retcode, files, ic_names, diag_names + return retcode, files, ic_names def main(): """Function to execute when module called as a script""" @@ -1915,5 +1838,5 @@ def main(): ############################################################################### if __name__ == "__main__": - __RETCODE, _FILES, _IC_NAMES, _DIAG_NAMES = main() + __RETCODE, _FILES, _IC_NAMES = main() sys.exit(__RETCODE) diff --git a/src/data/registry.xml b/src/data/registry.xml index 6bf3b67a..6b9cd079 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -31,21 +31,18 @@ allocatable="pointer"> horizontal_dimension ps state_ps - horizontal_dimension psdry state_psdry - horizontal_dimension phis state_phis - Air temperature horizontal_dimension vertical_layer_dimension T state_t - Horizontal wind in a direction perpendicular to northward_wind horizontal_dimension vertical_layer_dimension u state_u - Horizontal wind in a direction perpendicular to eastward_wind horizontal_dimension vertical_layer_dimension v state_v - horizontal_dimension vertical_layer_dimension s state_s - Vertical pressure velocity horizontal_dimension vertical_layer_dimension omega state_omega - horizontal_dimension vertical_layer_dimension pmid state_pmid - horizontal_dimension vertical_layer_dimension pdeldry state_pdeldry - horizontal_dimension vertical_layer_dimension zm state_zm - horizontal_dimension vertical_interface_dimension zi state_zi - Change in temperature from a parameterization horizontal_dimension vertical_layer_dimension dTdt tend_dtdt - Change in eastward wind from a parameterization horizontal_dimension vertical_layer_dimension dudt tend_dudt - Change in northward wind from a parameterization horizontal_dimension vertical_layer_dimension dvdt tend_dvdt - inverse_exner_function_wrt_surface_pressure frontogenesis_function frontogenesis_angle + vertically_integrated_energies_of_initial_state_in_cam + vertically_integrated_energies_of_current_state_in_cam + vertically_integrated_total_water_of_initial_state + vertically_integrated_total_water_of_current_state tendency_of_air_temperature_due_to_model_physics @@ -403,7 +392,6 @@ Water vapor mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension Q cnst_Q - Cloud water mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension CLDLIQ cnst_CLDLIQ - Cloud ice mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension CLDICE cnst_CLDICE - rain mass mixing ratio with respect to moist air plus all airborne condensates horizontal_dimension vertical_layer_dimension RAINQM cnst_RAINQM - diff --git a/src/data/write_hist_file.py b/src/data/write_hist_file.py deleted file mode 100644 index ea9bc422..00000000 --- a/src/data/write_hist_file.py +++ /dev/null @@ -1,595 +0,0 @@ -#!/usr/bin/env python3 - -""" -Use variable meta-data from "generate_registry_data.py" -to generate a CAM fortran file that manage host model -variable history add and out fields -""" - -# Python library import statements: -from collections import OrderedDict -import os.path - -# CCPP Framework import statements -from ccpp_state_machine import CCPP_STATE_MACH -from fortran_tools import FortranWriter -from var_props import is_horizontal_dimension, is_vertical_dimension - -# Exclude these standard names from init processing -# Some are internal names (e.g., suite_name) -# Some are from the CCPP framework (e.g., ccpp_num_constituents) -# Some are for efficiency and to avoid dependency loops (e.g., log_output_unit) -_EXCLUDED_STDNAMES = {'suite_name', 'suite_part', - 'number_of_ccpp_constituents', - 'number_of_ccpp_advected_constituents', - 'ccpp_constituents', - 'ccpp_constituent_properties', - 'ccpp_constituent_minimum_values', - 'ccpp_error_message', - 'ccpp_error_code', - 'log_output_unit', 'do_log_output', - 'mpi_communicator', 'mpi_root', 'mpi_rank', - 'number_of_mpi_tasks'} -# Variable input types -_INPUT_TYPES = set(['in', 'inout']) - -# Include files to insert in the module preamble -_PHYS_VARS_PREAMBLE_INCS = ["cam_var_init_marks_decl.inc"] -# Include files to insert in the module body -_PHYS_VARS_BODY_INCS = ["cam_var_init_marks.inc"] - -# Increase allowed line lengths needed to fit extra-long CCPP standard names: -_LINE_FILL_LEN = 150 -_MAX_LINE_LEN = 200 - -############## -#Main function -############## - -def write_hist_file(cap_database, diag_names, outdir, file_find_func, - source_paths, indent, logger, phys_hist_filename=None): - - """ - Create the physics history Fortran file using a database - created by the CCPP Framework generator (capgen). - The specific Fortran file is: - - physics_history.F90 - - This file contains two public subroutines: - - physics_history_init - Includes calls to history_add_field - for each physics variable from the registry - - physics_history_out - Includes calls to history_out_field - for each physics variable from the registry - - """ - - #Initialize return message: - retmsg = "" - - # Gather all the host model variables that are required by - # any of the compiled CCPP physics suites. - host_vars, constituent_set, retmsg = gather_ccpp_req_vars(cap_database) - - # Quit now if there are missing variables - if retmsg: - return retmsg - # end if - - # Generate "physics_history.F90" file: - # ----------------------------------------- - - # Open new file: - if phys_hist_filename: - ofilename = os.path.join(outdir, phys_hist_filename) - # Get file name, ignoring file type: - physics_history_fname_str = os.path.splitext(phys_hist_filename)[0] - else: - ofilename = os.path.join(outdir, "physics_history.F90") - physics_history_fname_str = "physics_history" - # end if - - # Log file creation: - logger.info(f"Writing physics history source file, {ofilename}") - - # Open file using CCPP's FortranWriter: - file_desc = "Physics history source file" - with FortranWriter(ofilename, "w", file_desc, - physics_history_fname_str, - line_fill=_LINE_FILL_LEN, - line_max=_MAX_LINE_LEN, - indent=indent) as outfile: - - # Add boilerplate code: - outfile.write_preamble() - outfile.blank_line() - - # Add public function declarations: - outfile.write("!! public interfaces", 0) - outfile.write("public :: physics_history_init", 1) - outfile.write("public :: physics_history_out", 1) - - # Add "contains" statement: - outfile.end_module_header() - outfile.blank_line() - - # Grab the host dictionary from the database - host_dict = cap_database.host_model_dict() - - # Collect imported host variables - host_imports = collect_host_var_imports(host_vars, host_dict, constituent_set, diag_names) - - # Write physics_history_init subroutine: - write_physics_history_init_subroutine(outfile, host_dict, host_vars, host_imports, - diag_names, physics_history_fname_str, constituent_set) - - outfile.blank_line() - - # Write physics_history_out subroutine: - write_physics_history_out_subroutine(outfile, host_dict, host_vars, host_imports, - diag_names, physics_history_fname_str, constituent_set) - - # -------------------------------------- - - # Return retmsg: - return retmsg - -############################### -#Fortran generation error class -############################### - -class CamInitWriteError(ValueError): - """Class used to handle CAM write_init errors - (e.g., log user errors without backtrace)""" - # pylint: disable=useless-super-delegation - def __init__(self, message): - super().__init__(message) - # pylint: enable=useless-super-delegation - -################# -#HELPER FUNCTIONS -################# - -############################################################################## -def _find_and_add_host_variable(stdname, host_dict, var_dict): - """Find in and add it to if found and - not of type, 'host'. - If not found, add to . - If found and added to , also process the standard names of - any intrinsic sub-elements of . - Return the list of (if any). - Note: This function has a side effect (adding to ). - """ - missing_vars = [] - hvar = host_dict.find_variable(stdname) - if hvar and (hvar.source.ptype != 'host'): - var_dict[stdname] = hvar - # Process elements (if any) - ielem = hvar.intrinsic_elements() - # List elements are the only ones we care about - if isinstance(ielem, list): - for sname in ielem: - smissing = _find_and_add_host_variable(sname, host_dict, - var_dict) - missing_vars.extend(smissing) - # end for - # end if - # end if - if not hvar: - missing_vars.append(stdname) - # end if - return missing_vars - -############################################################################## -def gather_ccpp_req_vars(cap_database): - """ - Generate a list of host-model and constituent variables - required by the CCPP physics suites potentially being used - in this model run. - is the database object returned by capgen. - It is an error if any physics suite variable is not accessible in - the host model. - Return several values: - - A list of host model variables - - An error message (blank for no error) - """ - - # Dictionary of all 'in' and 'inout' suite variables. - # Key is standard name, value is host-model or constituent variable - req_vars = {} - missing_vars = set() - constituent_vars = set() - retmsg = "" - # Host model dictionary - host_dict = cap_database.host_model_dict() - - # Create CCPP datatable required variables-listing object: - # XXgoldyXX: Choose only some phases here? - for phase in CCPP_STATE_MACH.transitions(): - for cvar in cap_database.call_list(phase).variable_list(): - stdname = cvar.get_prop_value('standard_name') - intent = cvar.get_prop_value('intent') - is_const = cvar.get_prop_value('advected') - if ((intent in _INPUT_TYPES) and - (stdname not in req_vars) and - (stdname not in _EXCLUDED_STDNAMES)): - if is_const: - #Variable is a constituent, so may not be known - #until runtime, but still need variable names in order - #to read from a file if need be: - req_vars[stdname] = cvar - - #Add variable to constituent set: - constituent_vars.add(stdname) - else: - # We need to work with the host model version of this variable - missing = _find_and_add_host_variable(stdname, host_dict, - req_vars) - missing_vars.update(missing) - # end if - # end if (do not include output variables) - # end for (loop over call list) - # end for (loop over phases) - if missing_vars: - mvlist = ', '.join(sorted(missing_vars)) - retmsg = f"Error: Missing required host variables: {mvlist}" - # end if - # Return the required variables as a list - return list(req_vars.values()), constituent_vars, retmsg - -########################## -#FORTRAN WRITING FUNCTIONS -########################## - -def _get_host_model_import(hvar, import_dict, host_dict): - """Add import information (module, local_name) for to - . is used to look up any sub-variables - (e.g., array indices). - Note: This function has side effects but no return value - """ - missing_indices = [] - # Extract module name: - use_mod_name = hvar.source.name - # Check if module name is already in dictionary: - if use_mod_name not in import_dict: - # Create an empty entry for this module - import_dict[use_mod_name] = set() - # end if - # Add the variable - var_locname = hvar.var.get_prop_value('local_name') - import_dict[use_mod_name].add(var_locname) - aref = hvar.array_ref() - if aref: - dimlist = [x.strip() for x in aref.group(2).split(',')] - for dim in dimlist: - if dim != ':': - dvar = host_dict.find_variable(dim) - if dvar: - _get_host_model_import(dvar, import_dict, host_dict) - else: - missing_indices.append(dim) - # end if - # end if - # end for - # end if - if missing_indices: - mi_str = ", ".join(missing_indices) - raise CamInitWriteError(f"Missing host indices: {mi_str}.") - # end if - -def collect_host_var_imports(host_vars, host_dict, constituent_set, diag_dict): - """Construct a dictionary of host-model variables to import keyed by - host-model module name. - is used to look up array-reference indices. - Return a list of module / import vars combinations of the following form: - [[, [. - """ - - # The plus one is for a comma - max_modname = max(len(x[0]) for x in use_stmts) + 1 - # max_modspace is the max chars of the module plus other 'use' statement - # syntax (e.g., 'only:') - max_modspace = (outfile.indent_size * indent) + max_modname + 10 - mod_space = outfile.line_fill - max_modspace - for use_item in use_stmts: - # Break up imported interfaces to clean up use statements - larg = 0 - num_imports = len(use_item[1]) - while larg < num_imports: - int_str = use_item[1][larg] - larg = larg + 1 - while ((larg < num_imports) and - ((len(int_str) + len(use_item[1][larg]) + 2) < mod_space)): - int_str += f", {use_item[1][larg]}" - larg = larg + 1 - # end while - modname = use_item[0] + ',' - outfile.write(f"use {modname: <{max_modname}} only: {int_str}", - indent) - # end while - # end for - -###### - -def get_dimension_info(hvar): - """Retrieve dimension information from . - Return the following values: - - The local variable name of the vertical dimension (or None) - - True if has one dimension which is a horizontal dimension or - if has two dimensions (horizontal and vertical) - """ - vdim_name = None - legal_dims = False - fail_reason = "" - dims = hvar.get_dimensions() - levnm = hvar.has_vertical_dimension() - # is only 'legal' for 2 or 3 dimensional fields (i.e., 1 or 2 - # dimensional variables). The second dimension must be vertical. - # XXgoldyXX: If we ever need to read scalars, it would have to be - # done using global attributes, not 'infld'. - ldims = len(dims) - lname = hvar.get_prop_value('local_name') - suff = "" - legal_dims = True - if not hvar.has_horizontal_dimension(): - legal_dims = False - fail_reason += f"{suff}{lname} has no horizontal dimension" - suff = "; " - # end if - if (ldims > 2) or ((ldims > 1) and (not levnm)): - legal_dims = False - unsupp = [] - for dim in dims: - if ((not is_horizontal_dimension(dim)) and - (not is_vertical_dimension(dim))): - if dim[0:18] == "ccpp_constant_one:": - rdim = dim[18:] - else: - rdim = dim - # end if - unsupp.append(rdim) - # end if - # end for - if len(unsupp) > 1: - udims = ', '.join(unsupp[:-1]) - if len(unsupp) > 2: - udims += ',' - # end if - udims += f" and {unsupp[-1]}" - fail_reason += f"{suff}{lname} has unsupported dimensions, {udims}." - else: - udims = unsupp[0] if unsupp else "unknown" - fail_reason += f"{suff}{lname} has unsupported dimension, {udims}." - # end if - suff = "; " - # end if - if legal_dims and levnm: - # should be legal, find the correct local name for the - # vertical dimension - dparts = levnm.split(':') - if (len(dparts) == 2) and (dparts[0].lower() == 'ccpp_constant_one'): - levnm = dparts[1] - elif len(dparts) == 1: - levnm = dparts[0] - else: - # This should not happen so crash - raise ValueError(f"Unsupported vertical dimension, '{levnm}'") - # end if - if levnm == 'vertical_layer_dimension': - vdim_name = "lev" - elif levnm == 'vertical_interface_dimension': - vdim_name = "ilev" - # end if (no else, will be processed as an error below) - - if vdim_name is None: - # This should not happen so crash - raise ValueError(f"Vertical dimension, '{levnm}', not found") - # end if - # end if - return vdim_name, legal_dims, fail_reason - -def write_physics_history_init_subroutine(outfile, host_dict, host_vars, host_imports, - diag_dict, phys_check_fname_str, constituent_set): - - """ - Write the "physics_history_init" subroutine, which - is used to call history_add_field for all - physics variables. - """ - - # ----------------------------------------- - # Write subroutine code: - # ----------------------------------------- - - # Add subroutine header - outfile.write(f"subroutine physics_history_init()", 1) - - # Add use statements: - use_stmts = [["cam_ccpp_cap", ["cam_model_const_properties"]], - ["cam_history", ["history_add_field"]], - ["cam_history_support", ["horiz_only"]], - ["cam_constituents", ["const_get_index"]], - ["ccpp_constituent_prop_mod", ["ccpp_constituent_prop_ptr_t"]]] - - # Add in host model data use statements - use_stmts.extend(host_imports) - write_use_statements(outfile, use_stmts, 2) - outfile.blank_line() - - # Write local variable declarations: - outfile.comment("Local variables:", 2) - outfile.blank_line() - - outfile.write('integer :: const_index', 2) - outfile.write('integer :: errcode', 2) - outfile.write('logical :: const_is_dry', 2) - outfile.write('character(len=256) :: errmsg', 2) - outfile.write('type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:)', 2) - subn_str = 'character(len=*), parameter :: subname = "physics_history_init"' - outfile.write(subn_str, 2) - outfile.blank_line() - - # ----------------------------------------- - # Create Fortran "history_add_field" calls: - # ----------------------------------------- - - # Loop over all variable standard names: - for hvar in host_vars: - var_stdname = hvar.get_prop_value('standard_name') - var_locname = hvar.call_string(host_dict) - var_units = hvar.get_prop_value('units') - vdim_name, legal_dims, fail_reason = get_dimension_info(hvar) - if vdim_name is not None: - vdim = f"'{vdim_name}'" - else: - vdim = 'horiz_only' - # end if - - # only add add_field call if the variable has a diagnostic name - if var_stdname not in diag_dict: - continue - # end if - - diag_name = diag_dict[var_stdname][0] - diag_flag = diag_dict[var_stdname][1] - - # Ignore any variable that is listed as a constiutuent, - # as they will be handled separately by the constituents object: - if var_stdname in constituent_set: - outfile.write(f"call const_get_index('{var_stdname}', const_index, abort=.false., warning=.false.)", 2) - outfile.write("if (const_index >= 0) then", 2) - outfile.write("const_props_ptr => cam_model_const_properties()", 3) - outfile.write("call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg)", 3) - outfile.write("if (const_is_dry) then", 3) - outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ - f"{vdim}, '{diag_flag}', '{var_units}', mixing_ratio='dry')" - outfile.write(outstr, 4) - outfile.write("else", 3) - outstr = f"call history_add_field('{diag_name}', '{var_stdname}', " \ - f"{vdim}, '{diag_flag}', '{var_units}', mixing_ratio='wet')" - outfile.write(outstr, 4) - outfile.write("end if", 3) - outfile.write("end if", 2) - else: - outstr = f"call history_add_field('{diag_name}', '{var_stdname}', {vdim}, '{diag_flag}', '{var_units}')" - outfile.write(outstr, 2) - # end if - # end for - # End subroutine: - outfile.blank_line() - outfile.write("end subroutine physics_history_init", 1) - -##### - -def write_physics_history_out_subroutine(outfile, host_dict, host_vars, host_imports, - diag_dict, phys_check_fname_str, constituent_set): - - """ - Write the "physics_history_out" subroutine, which - is used to call history_out_field for all - physics variables in the registry. - """ - - # ----------------------------------------- - # Write subroutine code: - # ----------------------------------------- - - # Add subroutine header - outfile.write(f"subroutine physics_history_out()", 1) - - # Add use statements: - use_stmts = [["cam_ccpp_cap", ["cam_constituents_array"]], - ["cam_history", ["history_out_field"]], - ["cam_constituents", ["const_get_index"]], - ["ccpp_kinds", ["kind_phys"]], - ["ccpp_constituent_prop_mod", ["ccpp_constituent_prop_ptr_t"]]] - - # Add in host model data use statements - use_stmts.extend(host_imports) - write_use_statements(outfile, use_stmts, 2) - outfile.blank_line() - - # Write local variable declarations: - outfile.comment("Local variables:", 2) - outfile.blank_line() - - outfile.write('!! Local variables', 2) - outfile.write('real(kind_phys), pointer :: const_data_ptr(:,:,:)', 2) - outfile.write('character(len=512) :: standard_name', 2) - outfile.write('integer :: const_index', 2) - subn_str = 'character(len=*), parameter :: subname = "physics_history_out"' - outfile.write(subn_str, 2) - outfile.blank_line() - - # ----------------------------------------- - # Create Fortran "history_add_field" calls: - # ----------------------------------------- - - # Loop over all variable standard names: - for hvar in host_vars: - var_stdname = hvar.get_prop_value('standard_name') - var_locname = hvar.call_string(host_dict) - - # only add add_field call if the variable has a diagnostic name - if var_stdname not in diag_dict: - continue - # end if - - diag_name = diag_dict[var_stdname][0] - - # Ignore any variable that is listed as a constiutuent, - # as they will be handled separately by the constituents object: - if var_stdname in constituent_set: - outfile.write(f"call const_get_index('{var_stdname}', const_index, abort=.false., warning=.false.)", 2) - outfile.write("if (const_index >= 0) then", 2) - outfile.write("const_data_ptr => cam_constituents_array()", 3) - outstr = f"call history_out_field('{diag_name}', const_data_ptr(:,:,const_index))" - outfile.write(outstr, 3) - outfile.write("end if", 2) - else: - outstr = f"call history_out_field('{diag_name}', {var_locname})" - outfile.write(outstr, 2) - # end if - # end for - # End subroutine: - outfile.blank_line() - outfile.write("end subroutine physics_history_out", 1) - - # ---------------------------- - -############# -# End of file -############# diff --git a/src/physics/utils/physics_data.F90 b/src/physics/utils/physics_data.F90 index 2ba23746..62070f9f 100644 --- a/src/physics/utils/physics_data.F90 +++ b/src/physics/utils/physics_data.F90 @@ -68,6 +68,8 @@ integer function find_input_name_idx(stdname, use_init_variables, constituent_in if (find_input_name_idx >= 0) then constituent_index = find_input_name_idx is_constituent = .true. + else + find_input_name_idx = no_exist_idx end if !Loop through physics variable standard names: diff --git a/test/run_unit_tests.sh b/test/run_unit_tests.sh index d92a248a..874d72d8 100755 --- a/test/run_unit_tests.sh +++ b/test/run_unit_tests.sh @@ -78,8 +78,6 @@ run_unittest test/unit/test_registry.py run_unittest test/unit/test_create_readnl_files.py # Physics variable init (phys_init) generator unit tests: run_unittest test/unit/test_write_init_files.py -# Physics variable history generator unit tests: -run_unittest test/unit/test_write_hist_file.py # ParamGen atm_in namelist writer unit tests: run_unittest test/unit/test_atm_in_paramgen.py # CAM history config unit tests diff --git a/test/unit/sample_files/build_cache_files/example_build_cache.xml b/test/unit/sample_files/build_cache_files/example_build_cache.xml index 4530d6c1..f10dfd27 100644 --- a/test/unit/sample_files/build_cache_files/example_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/example_build_cache.xml @@ -3,7 +3,6 @@ - none /yellow/brick/road/munchkin.meta diff --git a/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml b/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml index ca7a10c3..7b84bf52 100644 --- a/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_ccpp_build_cache.xml @@ -2,7 +2,6 @@ - none diff --git a/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml b/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml index eb142a1c..62a8909a 100644 --- a/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_init_gen_build_cache.xml @@ -2,7 +2,6 @@ - none diff --git a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml index 54ba7645..e773ee2c 100644 --- a/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml +++ b/test/unit/sample_files/build_cache_files/update_reg_build_cache.xml @@ -2,14 +2,12 @@ - banana tmp/cam_build_cache/test_reg.xml heart brain - TOTO diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 deleted file mode 100644 index 355122bb..00000000 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt.F90 +++ /dev/null @@ -1,74 +0,0 @@ -! -! This work (Common Community Physics Package Framework), identified by -! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is -! placed in the public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - - -!> -!! @brief Auto-generated Physics history source file -!! -! -module physics_history_ddt - - - implicit none - private - - -!! public interfaces - public :: physics_history_init - public :: physics_history_out - -CONTAINS - - subroutine physics_history_init() - use cam_ccpp_cap, only: cam_model_const_properties - use cam_history, only: history_add_field - use cam_history_support, only: horiz_only - use cam_constituents, only: const_get_index - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt, only: phys_state, slp - - ! Local variables: - - integer :: const_index - integer :: errcode - logical :: const_is_dry - character(len=256) :: errmsg - type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) - character(len=*), parameter :: subname = "physics_history_init" - - call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') - call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') - - end subroutine physics_history_init - - subroutine physics_history_out() - use cam_ccpp_cap, only: cam_constituents_array - use cam_history, only: history_out_field - use cam_constituents, only: const_get_index - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt, only: phys_state, slp - - ! Local variables: - - !! Local variables - real(kind_phys), pointer :: const_data_ptr(:,:,:) - character(len=512) :: standard_name - integer :: const_index - character(len=*), parameter :: subname = "physics_history_out" - - call history_out_field('THETA', phys_state%theta) - call history_out_field('SLP', slp) - - end subroutine physics_history_out - -end module physics_history_ddt diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 deleted file mode 100644 index 380b116a..00000000 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt2.F90 +++ /dev/null @@ -1,74 +0,0 @@ -! -! This work (Common Community Physics Package Framework), identified by -! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is -! placed in the public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - - -!> -!! @brief Auto-generated Physics history source file -!! -! -module physics_history_ddt2 - - - implicit none - private - - -!! public interfaces - public :: physics_history_init - public :: physics_history_out - -CONTAINS - - subroutine physics_history_init() - use cam_ccpp_cap, only: cam_model_const_properties - use cam_history, only: history_add_field - use cam_history_support, only: horiz_only - use cam_constituents, only: const_get_index - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt2, only: phys_state - - ! Local variables: - - integer :: const_index - integer :: errcode - logical :: const_is_dry - character(len=256) :: errmsg - type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) - character(len=*), parameter :: subname = "physics_history_init" - - call history_add_field('THETA', 'potential_temperature', 'lev', 'avg', 'K') - call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') - - end subroutine physics_history_init - - subroutine physics_history_out() - use cam_ccpp_cap, only: cam_constituents_array - use cam_history, only: history_out_field - use cam_constituents, only: const_get_index - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt2, only: phys_state - - ! Local variables: - - !! Local variables - real(kind_phys), pointer :: const_data_ptr(:,:,:) - character(len=512) :: standard_name - integer :: const_index - character(len=*), parameter :: subname = "physics_history_out" - - call history_out_field('THETA', phys_state%theta) - call history_out_field('SLP', phys_state%slp) - - end subroutine physics_history_out - -end module physics_history_ddt2 diff --git a/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 b/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 deleted file mode 100644 index e6b3b0e1..00000000 --- a/test/unit/sample_files/write_hist_file/physics_history_ddt_array.F90 +++ /dev/null @@ -1,74 +0,0 @@ -! -! This work (Common Community Physics Package Framework), identified by -! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is -! placed in the public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - - -!> -!! @brief Auto-generated Physics history source file -!! -! -module physics_history_ddt_array - - - implicit none - private - - -!! public interfaces - public :: physics_history_init - public :: physics_history_out - -CONTAINS - - subroutine physics_history_init() - use cam_ccpp_cap, only: cam_model_const_properties - use cam_history, only: history_add_field - use cam_history_support, only: horiz_only - use cam_constituents, only: const_get_index - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt_array, only: ix_theta, phys_state - - ! Local variables: - - integer :: const_index - integer :: errcode - logical :: const_is_dry - character(len=256) :: errmsg - type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) - character(len=*), parameter :: subname = "physics_history_init" - - call history_add_field('THETA', 'potential_temperature', 'lev', 'lst', 'K') - call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'lst', 'Pa') - - end subroutine physics_history_init - - subroutine physics_history_out() - use cam_ccpp_cap, only: cam_constituents_array - use cam_history, only: history_out_field - use cam_constituents, only: const_get_index - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_ddt_array, only: ix_theta, phys_state - - ! Local variables: - - !! Local variables - real(kind_phys), pointer :: const_data_ptr(:,:,:) - character(len=512) :: standard_name - integer :: const_index - character(len=*), parameter :: subname = "physics_history_out" - - call history_out_field('THETA', phys_state%T(:, :, ix_theta)) - call history_out_field('SLP', phys_state%slp) - - end subroutine physics_history_out - -end module physics_history_ddt_array diff --git a/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 b/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 deleted file mode 100644 index 5409d491..00000000 --- a/test/unit/sample_files/write_hist_file/physics_history_no_req_var.F90 +++ /dev/null @@ -1,68 +0,0 @@ -! -! This work (Common Community Physics Package Framework), identified by -! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is -! placed in the public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - - -!> -!! @brief Auto-generated Physics history source file -!! -! -module physics_history_no_req_var - - - implicit none - private - - -!! public interfaces - public :: physics_history_init - public :: physics_history_out - -CONTAINS - - subroutine physics_history_init() - use cam_ccpp_cap, only: cam_model_const_properties - use cam_history, only: history_add_field - use cam_history_support, only: horiz_only - use cam_constituents, only: const_get_index - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - - ! Local variables: - - integer :: const_index - integer :: errcode - logical :: const_is_dry - character(len=256) :: errmsg - type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) - character(len=*), parameter :: subname = "physics_history_init" - - - end subroutine physics_history_init - - subroutine physics_history_out() - use cam_ccpp_cap, only: cam_constituents_array - use cam_history, only: history_out_field - use cam_constituents, only: const_get_index - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - - ! Local variables: - - !! Local variables - real(kind_phys), pointer :: const_data_ptr(:,:,:) - character(len=512) :: standard_name - integer :: const_index - character(len=*), parameter :: subname = "physics_history_out" - - - end subroutine physics_history_out - -end module physics_history_no_req_var diff --git a/test/unit/sample_files/write_hist_file/physics_history_simple.F90 b/test/unit/sample_files/write_hist_file/physics_history_simple.F90 deleted file mode 100644 index f73e5ac6..00000000 --- a/test/unit/sample_files/write_hist_file/physics_history_simple.F90 +++ /dev/null @@ -1,87 +0,0 @@ -! -! This work (Common Community Physics Package Framework), identified by -! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is -! placed in the public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - - -!> -!! @brief Auto-generated Physics history source file -!! -! -module physics_history_simple - - - implicit none - private - - -!! public interfaces - public :: physics_history_init - public :: physics_history_out - -CONTAINS - - subroutine physics_history_init() - use cam_ccpp_cap, only: cam_model_const_properties - use cam_history, only: history_add_field - use cam_history_support, only: horiz_only - use cam_constituents, only: const_get_index - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_simple, only: slp - - ! Local variables: - - integer :: const_index - integer :: errcode - logical :: const_is_dry - character(len=256) :: errmsg - type(ccpp_constituent_prop_ptr_t), pointer :: const_props_ptr(:) - character(len=*), parameter :: subname = "physics_history_init" - - call history_add_field('SLP', 'air_pressure_at_sea_level', horiz_only, 'avg', 'Pa') - call const_get_index('super_cool_cat_const', const_index, abort=.false., warning=.false.) - if (const_index >= 0) then - const_props_ptr => cam_model_const_properties() - call const_props_ptr(const_index)%is_dry(const_is_dry, errcode, errmsg) - if (const_is_dry) then - call history_add_field('COOL_CAT', 'super_cool_cat_const', 'lev', 'avg', 'kg kg-1', mixing_ratio='dry') - else - call history_add_field('COOL_CAT', 'super_cool_cat_const', 'lev', 'avg', 'kg kg-1', mixing_ratio='wet') - end if - end if - - end subroutine physics_history_init - - subroutine physics_history_out() - use cam_ccpp_cap, only: cam_constituents_array - use cam_history, only: history_out_field - use cam_constituents, only: const_get_index - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use physics_types_simple, only: slp - - ! Local variables: - - !! Local variables - real(kind_phys), pointer :: const_data_ptr(:,:,:) - character(len=512) :: standard_name - integer :: const_index - character(len=*), parameter :: subname = "physics_history_out" - - call history_out_field('SLP', slp) - call const_get_index('super_cool_cat_const', const_index, abort=.false., warning=.false.) - if (const_index >= 0) then - const_data_ptr => cam_constituents_array() - call history_out_field('COOL_CAT', const_data_ptr(:,:,const_index)) - end if - - end subroutine physics_history_out - -end module physics_history_simple diff --git a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml index 9c88fd1f..c5d96596 100644 --- a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml +++ b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml @@ -3,7 +3,6 @@ TAG2 - none diff --git a/test/unit/test_build_cache.py b/test/unit/test_build_cache.py index e0e2462c..ed17d094 100644 --- a/test/unit/test_build_cache.py +++ b/test/unit/test_build_cache.py @@ -423,12 +423,11 @@ def test_update_registry(self): #Set non-file update_registry inputs: ic_names = {"Only_had_a": ["heart", "brain"]} - diag_names = {"small_dog_wrt_dorothy": ('TOTO', 'avg')} dycore = "banana" #Update registry fields: test_cache.update_registry(tmp_test_reg, [tmp_test_reg], - dycore, [tmp_test_reg], ic_names, diag_names) + dycore, [tmp_test_reg], ic_names) #Write updated fields to build cache file: test_cache.write() diff --git a/test/unit/test_cam_autogen.py b/test/unit/test_cam_autogen.py index deda626b..78eca1d3 100644 --- a/test/unit/test_cam_autogen.py +++ b/test/unit/test_cam_autogen.py @@ -521,7 +521,7 @@ def test_generate_registry(self): test_data_search = [os.path.join(_CAM_ROOT_DIR, "src", "data")] #Set expected output tuple: - expected_results = (f'{self.test_bldroot}'+os.sep+'cam_registry', False, [], {}, {}) + expected_results = (f'{self.test_bldroot}'+os.sep+'cam_registry', False, [], {}) #Run registry generation function: gen_results = generate_registry(test_data_search, self.test_cache, _CAM_ROOT_DIR, diff --git a/test/unit/test_write_hist_file.py b/test/unit/test_write_hist_file.py deleted file mode 100644 index 5ebd1799..00000000 --- a/test/unit/test_write_hist_file.py +++ /dev/null @@ -1,486 +0,0 @@ -#! /usr/bin/env python3 -#----------------------------------------------------------------------- -# Description: Contains unit tests for testing CAM "physics_history" code -# generation using the registry and CCPP physics suites. -# -# Assumptions: -# -# Command line arguments: none -# -# Usage: python "test_write_hist_file.py" # run the unit tests -#----------------------------------------------------------------------- - -"""Test write_init_files in write_hist_file.py""" - -import sys -import os -import glob -import unittest -import filecmp -import logging - -__TEST_DIR = os.path.dirname(os.path.abspath(__file__)) -_CAM_ROOT = os.path.abspath(os.path.join(__TEST_DIR, os.pardir, os.pardir)) -__CCPP_DIR = os.path.join(_CAM_ROOT, "ccpp_framework", "scripts") -__REGISTRY_DIR = os.path.join(_CAM_ROOT, "src", "data") -_REG_SAMPLES_DIR = os.path.join(__TEST_DIR, "sample_files") -_HIST_SAMPLES_DIR = os.path.join(_REG_SAMPLES_DIR, "write_hist_file") -_INIT_SAMPLES_DIR = os.path.join(_REG_SAMPLES_DIR, "write_init_files") -_PRE_TMP_DIR = os.path.join(__TEST_DIR, "tmp") -_TMP_DIR = os.path.join(_PRE_TMP_DIR, "write_hist_file") -_SRC_MOD_DIR = os.path.join(_PRE_TMP_DIR, "SourceMods") -_INC_SEARCH_DIRS = [_SRC_MOD_DIR, __REGISTRY_DIR] - -__FILE_OPEN = (lambda x: open(x, 'r', encoding='utf-8')) - -#Check for all necessary directories: -if not os.path.exists(__CCPP_DIR): - EMSG = "Cannot find CCPP framework directory where 'ccpp_capgen.py' should be located." - raise ImportError(EMSG) - -if not os.path.exists(__REGISTRY_DIR): - EMSG = "Cannot find registry directory where 'write_hist_files.py' should be located." - raise ImportError(EMSG) - -if not os.path.exists(_REG_SAMPLES_DIR): - raise ImportError("Cannot find sample files directory") - -if not os.path.exists(_INIT_SAMPLES_DIR): - raise ImportError("Cannot find 'write_init_files' sample files directory") - -if not os.path.exists(_HIST_SAMPLES_DIR): - raise ImportError("Cannot find 'write_hist_file' sample files directory") - -#Add CCPP framework directory to python path to -#import capgen code generator: -sys.path.append(__CCPP_DIR) - -#Add registry directory to python path to import -#registry and 'phys_init' code generators: -sys.path.append(__REGISTRY_DIR) - -# pylint: disable=wrong-import-position -from ccpp_capgen import capgen -from framework_env import CCPPFrameworkEnv -from generate_registry_data import gen_registry -import write_hist_file as write_hist -# pylint: enable=wrong-import-position - -############################################################################### -def remove_files(file_list): -############################################################################### - """Remove files in if they exist""" - for fpath in file_list: - if os.path.exists(fpath): - os.remove(fpath) - # End if - # End for - -############################################################################### -def find_file(filename, search_dirs): -############################################################################### - """Look for in . - Return the found path and the match directory (from ). - """ - match_file = None - for sdir in search_dirs: - test_path = os.path.join(sdir, filename) - if os.path.exists(test_path): - match_file = test_path - break - # End if - # End for - return match_file - -############################################################################### - -class WriteHistTest(unittest.TestCase): - - """Tests for `write_hist_files`.""" - - @classmethod - def setUpClass(cls): - """Clean output directory (tmp) before running tests""" - # Does "tmp" directory exist? If not then create it: - if not os.path.exists(_PRE_TMP_DIR): - os.mkdir(_PRE_TMP_DIR) - # end if - # Now check if "write_init_files" directory exists: - if not os.path.exists(_TMP_DIR): - os.mkdir(_TMP_DIR) - # end if - # Finally check if "SourceMods" directory exists: - if not os.path.exists(_SRC_MOD_DIR): - os.mkdir(_SRC_MOD_DIR) - # end if - - # Clear out all files: - remove_files(glob.iglob(os.path.join(_TMP_DIR, '*.*'))) - - # Run inherited setup method: - super(cls, WriteHistTest).setUpClass() - - def test_simple_reg_write_hist(self): - """ - Test that the 'write_hist_files' function - generates the correct Fortran code given - a simple registry and CCPP physics suite with - only regular variables. - """ - - # Setup registry inputs: - filename = os.path.join(_INIT_SAMPLES_DIR, "simple_reg.xml") - out_source_name = "physics_types_simple" - out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') - out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') - - out_hist_name = "physics_history_simple.F90" - out_hist = os.path.join(_TMP_DIR, out_hist_name) - - # Setup capgen inputs: - model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") - sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") - scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust_cnst.meta") - cap_datafile = os.path.join(_TMP_DIR, "datatable_cnst.xml") - - host_files = [model_host, out_meta] - - # Setup comparison files - in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) - - # Create local logger: - logger = logging.getLogger("write_hist_file_simple") - - # Clear all temporary output files: - remove_files([out_source, cap_datafile, out_meta, out_hist]) - - # Generate registry files: - _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, - _SRC_MOD_DIR, _CAM_ROOT, - loglevel=logging.ERROR, - error_on_no_validate=True) - - # Generate CCPP capgen files: - kind_types = ['kind_phys=REAL64'] - run_env = CCPPFrameworkEnv(logger, host_files=host_files, - scheme_files=scheme_files, suites=sdf, - preproc_directives='', - generate_docfiles=False, - host_name='cam', kind_types=kind_types, - use_error_obj=False, - force_overwrite=True, - output_root=_TMP_DIR, - ccpp_datafile=cap_datafile) - - cap_database = capgen(run_env, return_db=True) - - # Generate physics initialization files: - retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, - find_file, _INC_SEARCH_DIRS, - 3, logger, - phys_hist_filename=out_hist_name) - - # Check return message: - amsg = f"Test failure: retmsg={retmsg}" - self.assertEqual(retmsg, '', msg=amsg) - - # Make sure each output file was created: - amsg = f"{out_hist} does not exist" - self.assertTrue(os.path.exists(out_hist), msg=amsg) - - # For each output file, make sure it matches input file - amsg = f"{out_hist} does not match {in_hist}" - self.assertTrue(filecmp.cmp(in_hist, out_hist, - shallow=False), msg=amsg) - - def test_no_reqvar_write_hist(self): - """ - Test that the 'write_hist_file' function - generates the correct Fortran code given - a CCPP physics suite with no required - variables from the registry. - """ - - # Setup registry inputs: - filename = os.path.join(_INIT_SAMPLES_DIR, "no_req_var_reg.xml") - out_source_name = "physics_types_no_req_var" - out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') - out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') - out_hist_name = "physics_history_no_req_var.F90" - out_hist = os.path.join(_TMP_DIR, out_hist_name) - - # Setup capgen inputs: - model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") - sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") - scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust_noreq.meta") - cap_datafile = os.path.join(_TMP_DIR, "datatable_no_req_var.xml") - - host_files = [model_host, out_meta] - - # Setup write_init_files inputs: - in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) - - # Create local logger: - logger = logging.getLogger("write_hist_file_noreq") - - # Clear all temporary output files: - remove_files([out_source, out_meta, cap_datafile, - out_hist]) - - # Generate registry files: - _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, - _SRC_MOD_DIR, _CAM_ROOT, - loglevel=logging.ERROR, - error_on_no_validate=True) - - # Generate CCPP capgen files: - kind_types = ['kind_phys=REAL64'] - run_env = CCPPFrameworkEnv(logger, host_files=host_files, - scheme_files=scheme_files, suites=sdf, - preproc_directives='', - generate_docfiles=False, - host_name='cam', kind_types=kind_types, - use_error_obj=False, - force_overwrite=True, - output_root=_TMP_DIR, - ccpp_datafile=cap_datafile) - - cap_database = capgen(run_env, return_db=True) - - # Generate physics initialization files: - retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, - find_file, _INC_SEARCH_DIRS, - 3, logger, - phys_hist_filename=out_hist_name) - - # Check return message: - amsg = f"Test failure: retmsg={retmsg}" - self.assertEqual(retmsg, '', msg=amsg) - - # Make sure each output file was created: - amsg = f"{out_hist} does not exist" - self.assertTrue(os.path.exists(out_hist), msg=amsg) - - # For each output file, make sure it matches input file - amsg = f"{out_hist} does not match {out_hist}" - self.assertTrue(filecmp.cmp(in_hist, out_hist, - shallow=False), msg=amsg) - - - def test_ddt_reg_write_init(self): - """ - Test that the 'write_hist_file' function - generates the correct Fortran code given - a registry which contains variables and - a DDT. - """ - - # Setup registry inputs: - filename = os.path.join(_INIT_SAMPLES_DIR, "ddt_reg.xml") - out_source_name = "physics_types_ddt" - out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') - out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') - out_hist_name = 'physics_history_ddt.F90' - out_hist = os.path.join(_TMP_DIR, out_hist_name) - - # Setup capgen inputs: - model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") - sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") - scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") - cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt.xml") - - host_files = [model_host, out_meta] - - # Setup write_init_files inputs: - in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) - - # Create local logger: - logger = logging.getLogger("write_hist_file_ddt") - - # Clear all temporary output files: - remove_files([out_source, out_meta, cap_datafile, out_hist]) - - # Generate registry files: - _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, - _SRC_MOD_DIR, _CAM_ROOT, - loglevel=logging.ERROR, - error_on_no_validate=True) - - # Generate CCPP capgen files: - kind_types=['kind_phys=REAL64'] - run_env = CCPPFrameworkEnv(logger, host_files=host_files, - scheme_files=scheme_files, suites=sdf, - preproc_directives='', - generate_docfiles=False, - host_name='cam', kind_types=kind_types, - use_error_obj=False, - force_overwrite=True, - output_root=_TMP_DIR, - ccpp_datafile=cap_datafile) - cap_database = capgen(run_env, return_db=True) - - # Generate physics initialization files: - retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, - find_file, _INC_SEARCH_DIRS, - 3, logger, - phys_hist_filename=out_hist_name) - - # Check return code: - amsg = f"Test failure: retmsg={retmsg}" - self.assertEqual(retmsg, '', msg=amsg) - - # Make sure each output file was created: - amsg = f"{out_hist} does not exist" - self.assertTrue(os.path.exists(out_hist), msg=amsg) - - # For each output file, make sure it matches input file - amsg = f"{out_hist} does not match {in_hist}" - self.assertTrue(filecmp.cmp(in_hist, out_hist, - shallow=False), msg=amsg) - - def test_ddt2_reg_write_init(self): - """ - Test that the 'write_init_files' function - generates the correct Fortran code given - a registry that contains variables and - a DDT, which itself contains another DDT. - """ - - # Setup registry inputs: - filename = os.path.join(_INIT_SAMPLES_DIR, "ddt2_reg.xml") - out_source_name = "physics_types_ddt2" - out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') - out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') - out_hist_name = "physics_history_ddt2.F90" - out_hist = os.path.join(_TMP_DIR, out_hist_name) - - # Setup capgen inputs: - model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") - sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") - scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") - cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt2.xml") - - host_files = [model_host, out_meta] - - # Comparison files - in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) - - # Create local logger: - logger = logging.getLogger("write_hist_file_ddt2") - - # Clear all temporary output files: - remove_files([out_source, out_meta, cap_datafile, out_hist]) - - # Generate registry files: - _, files, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, - _SRC_MOD_DIR, _CAM_ROOT, - loglevel=logging.ERROR, - error_on_no_validate=True) - - # Generate CCPP capgen files: - kind_types=['kind_phys=REAL64'] - run_env = CCPPFrameworkEnv(logger, host_files=host_files, - scheme_files=scheme_files, suites=sdf, - preproc_directives='', - generate_docfiles=False, - host_name='cam', kind_types=kind_types, - use_error_obj=False, - force_overwrite=True, - output_root=_TMP_DIR, - ccpp_datafile=cap_datafile) - cap_database = capgen(run_env, return_db=True) - - # Generate physics initialization files: - retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, - find_file, _INC_SEARCH_DIRS, - 3, logger, - phys_hist_filename=out_hist_name) - - # Check return code: - amsg = f"Test failure: retmsg={retmsg}" - self.assertEqual(retmsg, '', msg=amsg) - - # Make sure each output file was created: - amsg = f"{out_hist} does not exist" - self.assertTrue(os.path.exists(out_hist), msg=amsg) - - # For each output file, make sure it matches input file - amsg = f"{out_hist} does not match {in_hist}" - self.assertTrue(filecmp.cmp(out_hist, in_hist, - shallow=False), msg=amsg) - - def test_ddt_array_reg_write_init(self): - """ - Test that the 'write_hist_files' function - generates the correct Fortran code given - a registry which contains Array variables - and a DDT. - """ - - # Setup registry inputs: - filename = os.path.join(_INIT_SAMPLES_DIR, "ddt_array_reg.xml") - out_source_name = "physics_types_ddt_array" - out_source = os.path.join(_TMP_DIR, out_source_name + '.F90') - out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') - out_hist_name = "physics_history_ddt_array.F90" - out_hist = os.path.join(_TMP_DIR, out_hist_name) - - # Setup capgen inputs: - model_host = os.path.join(_INIT_SAMPLES_DIR,"simple_host.meta") - sdf = os.path.join(_INIT_SAMPLES_DIR,"suite_simple.xml") - scheme_files = os.path.join(_INIT_SAMPLES_DIR, "temp_adjust.meta") - cap_datafile = os.path.join(_TMP_DIR, "datatable_ddt_array.xml") - - host_files = [model_host, out_meta] - - # Setup write_init_files inputs: - in_hist = os.path.join(_HIST_SAMPLES_DIR, out_hist_name) - - # Create local logger: - logger = logging.getLogger("write_hist_file_ddt_array") - - # Clear all temporary output files: - remove_files([out_source, out_meta, cap_datafile, out_hist]) - - # Generate registry files: - _, _, _, diag_names = gen_registry(filename, 'se', _TMP_DIR, 3, - _SRC_MOD_DIR, _CAM_ROOT, - loglevel=logging.ERROR, - error_on_no_validate=True) - - # Generate CCPP capgen files: - kind_types=['kind_phys=REAL64'] - run_env = CCPPFrameworkEnv(logger, host_files=host_files, - scheme_files=scheme_files, suites=sdf, - preproc_directives='', - generate_docfiles=False, - host_name='cam', kind_types=kind_types, - use_error_obj=False, - force_overwrite=True, - output_root=_TMP_DIR, - ccpp_datafile=cap_datafile) - cap_database = capgen(run_env, return_db=True) - - # Generate physics initialization files: - retmsg = write_hist.write_hist_file(cap_database, diag_names, _TMP_DIR, - find_file, _INC_SEARCH_DIRS, - 3, logger, - phys_hist_filename=out_hist_name) - - # Check return code: - amsg = f"Test failure: retmsg={retmsg}" - self.assertEqual(retmsg, '', msg=amsg) - - # Make sure each output file was created: - amsg = f"{out_hist} does not exist" - self.assertTrue(os.path.exists(out_hist), msg=amsg) - - # For each output file, make sure it matches input file - amsg = f"{out_hist} does not match {in_hist}" - self.assertTrue(filecmp.cmp(out_hist, in_hist, - shallow=False), msg=amsg) - -########## - -if __name__ == '__main__': - unittest.main() From 8ac38388ad826ca57c8abc5a3eab5cc406159aa3 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Wed, 24 Jul 2024 15:32:32 -0600 Subject: [PATCH 60/79] fix unit tests --- test/unit/sample_files/reg_good_ddt.xml | 2 -- test/unit/sample_files/reg_good_ddt_array.xml | 3 --- test/unit/sample_files/reg_good_simple.xml | 2 -- .../sample_files/write_init_files/ddt2_reg.xml | 3 --- .../write_init_files/ddt_array_reg.xml | 2 -- .../sample_files/write_init_files/ddt_reg.xml | 2 -- .../write_init_files/no_req_var_reg.xml | 3 --- .../simple_build_cache_template.xml | 6 +++--- .../write_init_files/simple_reg.xml | 2 -- test/unit/test_registry.py | 18 +++++++++--------- test/unit/test_write_init_files.py | 14 +++++++------- 11 files changed, 19 insertions(+), 38 deletions(-) diff --git a/test/unit/sample_files/reg_good_ddt.xml b/test/unit/sample_files/reg_good_ddt.xml index 8d633a07..fe2fc701 100644 --- a/test/unit/sample_files/reg_good_ddt.xml +++ b/test/unit/sample_files/reg_good_ddt.xml @@ -15,7 +15,6 @@ allocatable="pointer" access="protected"> horizontal_dimension lat - Composition-dependent ratio of dry air gas constant to specific heat at constant pressure horizontal_dimension vertical_layer_dimension rair/cpair - horizontal_dimension diff --git a/test/unit/sample_files/reg_good_ddt_array.xml b/test/unit/sample_files/reg_good_ddt_array.xml index 40f2c891..5cc3adfc 100644 --- a/test/unit/sample_files/reg_good_ddt_array.xml +++ b/test/unit/sample_files/reg_good_ddt_array.xml @@ -17,7 +17,6 @@ units="count" type="integer" access="protected"> Number of horizontal columns 0 - horizontal_dimension lon - CLDLIQ CLDLIQ_snapshot - diff --git a/test/unit/sample_files/reg_good_simple.xml b/test/unit/sample_files/reg_good_simple.xml index c5b07390..5c227b7c 100644 --- a/test/unit/sample_files/reg_good_simple.xml +++ b/test/unit/sample_files/reg_good_simple.xml @@ -19,14 +19,12 @@ allocatable="pointer" access="protected"> horizontal_dimension lon - The coolest constituent imaginable COOL_CAT cnst_COOL_CAT - diff --git a/test/unit/sample_files/write_init_files/ddt2_reg.xml b/test/unit/sample_files/write_init_files/ddt2_reg.xml index 28bee48e..65f4e0c0 100644 --- a/test/unit/sample_files/write_init_files/ddt2_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt2_reg.xml @@ -7,19 +7,16 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp - horizontal_dimension slp sea_lev_pres - horizontal_dimension eddy_len - eddy_length_scale diff --git a/test/unit/sample_files/write_init_files/ddt_array_reg.xml b/test/unit/sample_files/write_init_files/ddt_array_reg.xml index 969e6959..504cd880 100644 --- a/test/unit/sample_files/write_init_files/ddt_array_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt_array_reg.xml @@ -12,7 +12,6 @@ units="Pa" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension slp sea_lev_pres - @@ -30,7 +29,6 @@ index_name="index_of_potential_temperature" index_pos="number_of_thermo_vars"> theta pot_temp - diff --git a/test/unit/sample_files/write_init_files/ddt_reg.xml b/test/unit/sample_files/write_init_files/ddt_reg.xml index 831ee949..0ec3079e 100644 --- a/test/unit/sample_files/write_init_files/ddt_reg.xml +++ b/test/unit/sample_files/write_init_files/ddt_reg.xml @@ -7,13 +7,11 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp - horizontal_dimension slp sea_lev_pres - diff --git a/test/unit/sample_files/write_init_files/no_req_var_reg.xml b/test/unit/sample_files/write_init_files/no_req_var_reg.xml index 59aec546..8546cf7e 100644 --- a/test/unit/sample_files/write_init_files/no_req_var_reg.xml +++ b/test/unit/sample_files/write_init_files/no_req_var_reg.xml @@ -7,19 +7,16 @@ units="K" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension vertical_layer_dimension theta pot_temp - horizontal_dimension slp sea_lev_pres - horizontal_dimension eddy_len - diff --git a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml index c5d96596..5f2d6351 100644 --- a/test/unit/sample_files/write_init_files/simple_build_cache_template.xml +++ b/test/unit/sample_files/write_init_files/simple_build_cache_template.xml @@ -1,10 +1,10 @@ TAG1 - + TAG2 - - + + none diff --git a/test/unit/sample_files/write_init_files/simple_reg.xml b/test/unit/sample_files/write_init_files/simple_reg.xml index f7920068..26f058cc 100644 --- a/test/unit/sample_files/write_init_files/simple_reg.xml +++ b/test/unit/sample_files/write_init_files/simple_reg.xml @@ -12,7 +12,6 @@ units="Pa" type="real" kind="kind_phys" allocatable="pointer"> horizontal_dimension slp sea_lev_pres - @@ -25,7 +24,6 @@ The coolest constituent imaginable horizontal_dimension vertical_layer_dimension COOL_CAT cnst_COOL_CAT - diff --git a/test/unit/test_registry.py b/test/unit/test_registry.py index fcb19d04..98d0a232 100644 --- a/test/unit/test_registry.py +++ b/test/unit/test_registry.py @@ -94,7 +94,7 @@ def test_good_simple_registry(self): out_meta = os.path.join(_TMP_DIR, out_source_name + '.meta') remove_files([out_source, out_meta]) # Run test - retcode, files, _, _ = gen_registry(filename, 'fv', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'fv', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -136,7 +136,7 @@ def test_good_ddt_registry(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _, _ = gen_registry(filename, dycore, _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, dycore, _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -183,7 +183,7 @@ def test_good_ddt_registry2(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -223,7 +223,7 @@ def test_good_array(self): out_meta = os.path.join(_TMP_DIR, out_meta_name) remove_files([out_source, out_meta]) # Run dycore - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -261,7 +261,7 @@ def test_good_metadata_file_registry(self): out_meta = os.path.join(_TMP_DIR, out_name + '.meta') remove_files([out_source, out_meta]) # generate registry - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -315,7 +315,7 @@ def test_diff_src_root_metadata_file_registry(self): shutil.copy(meta_file, tmp_src_dir) # Generate registry - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _TMP_DIR, loglevel=logging.ERROR, error_on_no_validate=True) @@ -372,7 +372,7 @@ def test_SourceMods_metadata_file_registry(self): shutil.copy(meta_file, source_mod_file) # Generate registry - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, tmp_src_dir, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -423,7 +423,7 @@ def test_good_complete_registry(self): remove_files([out_source, out_meta]) # Run test - retcode, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'se', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -530,7 +530,7 @@ def test_parameter(self): # End for tree.write(filename) # Run test - retcode, files, _, _ = gen_registry(filename, 'eul', _TMP_DIR, 2, + retcode, files, _ = gen_registry(filename, 'eul', _TMP_DIR, 2, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) diff --git a/test/unit/test_write_init_files.py b/test/unit/test_write_init_files.py index 7c57cdf2..d0736ee0 100644 --- a/test/unit/test_write_init_files.py +++ b/test/unit/test_write_init_files.py @@ -238,7 +238,7 @@ def test_simple_reg_constituent_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, _, ic_names, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, _, ic_names = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -403,7 +403,7 @@ def test_protected_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -572,7 +572,7 @@ def test_no_horiz_var_write_init(self): remove_files([out_source, out_meta, cap_datafile, check_init_out, phys_input_out]) # Generate registry files: - _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -647,7 +647,7 @@ def test_scalar_var_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -722,7 +722,7 @@ def test_4d_var_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -878,7 +878,7 @@ def test_ddt2_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, files, _, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, files, _ = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) @@ -959,7 +959,7 @@ def test_ddt_array_reg_write_init(self): check_init_out, phys_input_out]) # Generate registry files: - _, _, ic_names, _ = gen_registry(filename, 'se', _TMP_DIR, 3, + _, _, ic_names = gen_registry(filename, 'se', _TMP_DIR, 3, _SRC_MOD_DIR, _CAM_ROOT, loglevel=logging.ERROR, error_on_no_validate=True) From 48f0807378a08637c06b0c5f279a2be5c931e308 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Wed, 7 Aug 2024 14:27:11 -0600 Subject: [PATCH 61/79] fix to enable no history configurations in nl --- src/history/cam_hist_file.F90 | 10 +++++----- src/history/cam_history.F90 | 6 ++++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index 1a5b7b3f..ad81a0c4 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -2096,16 +2096,16 @@ subroutine hist_read_namelist_config(filename, config_arr) ! ! Cleanup ! - ! Special block for testing - call MPI_bcast(read_status, 1, MPI_INTEGER, masterprocid, mpicom, ierr) - if (read_status /= 0) then - return - end if ! Close unitn if it is still open inquire(unit=unitn, opened=filefound, iostat=ierr) if ((ierr == 0) .and. filefound) then close(unitn) end if + ! Special block for testing + call MPI_bcast(read_status, 1, MPI_INTEGER, masterprocid, mpicom, ierr) + if (read_status /= 0) then + return + end if if (allocated(hist_inst_fields)) then deallocate(hist_inst_fields) end if diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 index af89b5ca..400bbe96 100644 --- a/src/history/cam_history.F90 +++ b/src/history/cam_history.F90 @@ -478,8 +478,10 @@ subroutine history_add_field_nd(diagnostic_name, standard_name, dimnames, avgfla character(len=3) :: mixing_ratio_loc character(len=*), parameter :: subname = 'history_add_field_nd: ' - if (size(hist_configs) > 0 .and. hist_configs(1)%file_is_setup()) then - call endrun ('history_add_field_nd: Attempt to add field '//trim(diagnostic_name)//' after history files set') + if (size(hist_configs) > 0) then + if (hist_configs(1)%file_is_setup()) then + call endrun ('history_add_field_nd: Attempt to add field '//trim(diagnostic_name)//' after history files set') + end if end if ! Some checks for diagnostic_name From 9525b75dc2a6361f20d923104de2a1d6627136f1 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Fri, 9 Aug 2024 11:24:01 -0600 Subject: [PATCH 62/79] remove pio dependency from modular history to enable unit testing --- src/history/cam_hist_file.F90 | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 index ad81a0c4..ad5e1787 100644 --- a/src/history/cam_hist_file.F90 +++ b/src/history/cam_hist_file.F90 @@ -58,6 +58,7 @@ module cam_hist_file character(len=:), allocatable, private :: filename_spec character(len=max_fldlen), allocatable, private :: field_names(:) character(len=3), allocatable, private :: accumulate_types(:) + type(var_desc_t), allocatable, private :: file_varids(:,:) integer, allocatable, private :: grids(:) integer, private :: hfile_type = hfile_type_default logical, private :: collect_patch_output = PATCH_DEF @@ -995,6 +996,15 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) ! v peverwhee - remove when patch output is set up num_patches = 1 ! ^ peverwhee - remove when patch output is set up + varid_set = .true. + ! Allocate the varid array + if (.not. allocated(this%file_varids)) then + allocate(this%file_varids(size(this%field_list), num_patches), stat=ierr) + call check_allocate(ierr, subname, 'this%file_varids', & + file=__FILE__, line=__LINE__-1) + varid_set = .false. + end if + ! Format frequency write(time_per_freq,999) trim(this%output_freq_type), '_', this%output_freq_mult 999 format(2a,i0) @@ -1193,13 +1203,6 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) ! ! Create variables and atributes for fields written out as columns ! - varid_set = .true. - if(.not. this%field_list(field_index)%varid_set()) then - call this%field_list(field_index)%allocate_varid(num_patches, ierr) - call check_allocate(ierr, subname, 'field '//trim(this%field_list(field_index)%diag_name())//' varid', & - file=__FILE__, line=__LINE__-1) - varid_set = .false. - end if ! Find appropriate grid in header_info if (.not. allocated(header_info)) then ! Safety check @@ -1223,7 +1226,7 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) nacsdims(idx) = header_info(1)%get_hdimid(idx) end do do idx = 1, num_patches - varid = this%field_list(field_index)%varid(idx) + varid = this%file_varids(field_index, idx) dimids_tmp = dimindex ! Figure the dimension ID array for this field ! We have defined the horizontal grid dimensions in dimindex @@ -1242,7 +1245,7 @@ subroutine config_define_file(this, restart, logname, host, model_doi_url) call cam_pio_def_var(this%hist_files(split_file_index), trim(fname_tmp), ncreal, & dimids_tmp(1:fdims), varid) if (.not. varid_set) then - call this%field_list(field_index)%set_varid(idx, varid) + this%file_varids(field_index, idx) = varid end if if (mdimsize > 0) then ierr = pio_put_att(this%hist_files(split_file_index), varid, 'mdims', mdims(1:mdimsize)) @@ -1509,7 +1512,7 @@ subroutine config_write_time_dependent_variables(this, restart) split_file_index == instantaneous_file_index .and. .not. restart) then cycle end if - call this%write_field(this%field_list(field_idx), split_file_index, restart, start) + call this%write_field(this%field_list(field_idx), split_file_index, restart, start, field_idx) end do end do call t_stopf ('write_field') @@ -1519,7 +1522,7 @@ end subroutine config_write_time_dependent_variables ! ======================================================================== subroutine config_write_field(this, field, split_file_index, restart, & - sample_index) + sample_index, field_index) use pio, only: PIO_OFFSET_KIND, pio_setframe use cam_history_support, only: hist_coords use hist_buffer, only: hist_buffer_t @@ -1530,10 +1533,10 @@ subroutine config_write_field(this, field, split_file_index, restart, & ! Dummy arguments class(hist_file_t), intent(inout) :: this type(hist_field_info_t), intent(inout) :: field -! integer, intent(in) :: field_index integer, intent(in) :: split_file_index logical, intent(in) :: restart integer, intent(in) :: sample_index + integer, intent(in) :: field_index ! Local variables integer, allocatable :: field_shape(:) ! Field file dim sizes @@ -1580,7 +1583,7 @@ subroutine config_write_field(this, field, split_file_index, restart, & num_patches = 1 do patch_idx = 1, num_patches - varid = field%varid(patch_idx) + varid = this%file_varids(field_index, patch_idx) call pio_setframe(this%hist_files(split_file_index), varid, int(sample_index,kind=PIO_OFFSET_KIND)) buff_ptr => field%buffers if (frank == 1) then @@ -1624,9 +1627,7 @@ subroutine config_close_files(this) end do if(pio_file_is_open(this%hist_files(accumulated_file_index)) .or. & pio_file_is_open(this%hist_files(instantaneous_file_index))) then - do field_index = 1, size(this%field_list) - call this%field_list(field_index)%reset_varid() - end do + deallocate(this%file_varids) end if if (allocated(this%file_names)) then deallocate(this%file_names) From 8322b49b42d3959fe57af9d5f0a4fc378de2203e Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 29 Aug 2024 10:15:30 -0600 Subject: [PATCH 63/79] address one wave of review comments --- .gitmodules | 4 +- cime_config/buildnml | 20 -- cime_config/hist_config.py | 252 ++++++++++-------- src/data/registry.xml | 8 +- .../hist_config_files/amwg_hist_config | 3 +- .../hist_config_files/atm_in_multi | 4 +- .../hist_config_files/user_nl_cam_multi | 5 +- test/unit/test_cam_autogen.py | 6 - test/unit/test_hist_config.py | 88 +++++- 9 files changed, 225 insertions(+), 165 deletions(-) diff --git a/.gitmodules b/.gitmodules index c0b72575..f968ba5c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -7,7 +7,7 @@ [submodule "history"] path = src/history/buffers url = https://github.com/peverwhee/history_output - fxtag = sima-history + fxtag = 44099b18b2dcbb80c1ed1755b6ef1cc7be028033 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/peverwhee/history_output [submodule "mpas"] @@ -20,7 +20,7 @@ [submodule "ncar-physics"] path = src/physics/ncar_ccpp url = https://github.com/peverwhee/atmospheric_physics - fxtag = diagnostics + fxtag = 61bd9d3dac2abb11bb1e44a2ca34b401da0f44b1 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics [submodule "ccs_config"] diff --git a/cime_config/buildnml b/cime_config/buildnml index ddff8621..8989f291 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -307,26 +307,6 @@ def buildnml(case, caseroot, compname): user_nl_fname = "user_nl_cam" + inst_string user_nl_file = os.path.join(caseroot, user_nl_fname) - # Temporary user_nl file with history config stripped - user_nl_temp = os.path.join(confdir, "user_nl_temp") - if os.path.exists(user_nl_temp): - os.remove(user_nl_temp) - # end if - - # Remove history configuration from the normal user_nl content - with open(user_nl_file, 'r') as infile: - clines = infile.readlines() - # end with - with open(user_nl_temp, 'w') as outfile: - for line in clines: - sline = line.strip() - if ((not sline) or (sline[0] == '!') or - (_USER_NL_LINE.match(sline) is not None)): - outfile.write(line) - # end if - # end or - # end with - # Check that file actually exists. If not then throw an error: if not os.path.exists(user_nl_file): emsg = "The file 'user_nl_cam' is missing. Please run 'case.setup' first." diff --git a/cime_config/hist_config.py b/cime_config/hist_config.py index f00b53c0..65097be2 100644 --- a/cime_config/hist_config.py +++ b/cime_config/hist_config.py @@ -11,12 +11,12 @@ import sys # Find and include the ccpp-framework scripts directory -# Assume we are in /src/data and SPIN is in /ccpp_framework +# Assume we are in /src/data and CCPP is in /ccpp_framework __CURRDIR = os.path.abspath(os.path.dirname(__file__)) __CAMROOT = os.path.abspath(os.path.join(__CURRDIR, os.pardir)) -__SPINSCRIPTS = os.path.join(__CAMROOT, "ccpp_framework", 'scripts') -if __SPINSCRIPTS not in sys.path: - sys.path.append(__SPINSCRIPTS) +__CCPPSCRIPTS = os.path.join(__CAMROOT, "ccpp_framework", 'scripts') +if __CCPPSCRIPTS not in sys.path: + sys.path.append(__CCPPSCRIPTS) # end if # CCPP framework imports @@ -30,10 +30,10 @@ # %y = year, # %m = month, # %d = day, -# %s = seconds in day, +# %s = seconds since midnight GMT in current day, # %u = unit number (e.g., h0, i) # -# rhfilename_spec is the templdate for history restart files +# rhfilename_spec is the template for history restart files _DEFAULT_RESTART_HIST_SPEC = '%c.cam.r%u.%y-%m-%d-%s.nc' # hfilename_spec is the template for each history file _DEFAULT_HISTORY_SPEC = '%c.cam.%u.%y-%m-%d-%s.nc' @@ -41,11 +41,12 @@ # Note, these lists should match the corresponding lists in # cam_hist_config_file.F90 _TIME_PERIODS = ['nsteps', 'nstep', 'nseconds', 'nsecond', - 'nminutes', 'nminute', 'nhours', 'nhour', 'ndays', 'nday', - 'monthly', 'nmonths', 'nmonth', 'nyears', 'nyear', + 'nminutes', 'nminute', 'nhours', 'nhour', 'ndays', + 'nday', 'nmonths', 'nmonth', 'nyears', 'nyear', 'steps', 'seconds', 'minutes', 'hours', 'days', 'months', 'years'] _OUT_PRECS = ['REAL32', 'REAL64'] +_NETCDF_ID_RE = re.compile(r"^[a-z][a-z0-9_]{0,62}$", re.IGNORECASE) ############################################################################## ### @@ -64,12 +65,23 @@ def __init__(self, message): super().__init__(message) ############################################################################## -def blank_config_line(line): +def _blank_config_line(line): ############################################################################## """Return True if is a valid history config blank or comment line. Also return True if we have reached the end of the file - (no line)""" - return (not line) or (line.strip()[0] == '!') + (no line) + >>> _blank_config_line(" ! hist_add_avg_field") + True + >>> _blank_config_line(" ") + True + >>> _blank_config_line("") + True + >>> _blank_config_line("hist_add_avg_fields;h0: U") + False + >>> _blank_config_line("this is a ! weird line but is not blank") + False + """ + return (not line.strip()) or (line.strip()[0] == '!') ############################################################################## def _is_integer(entry): @@ -118,12 +130,16 @@ def _list_of_idents(entry, sep=','): (None, "'foo.3bar' is not a valid identifier") >>> _list_of_idents("foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd") (None, "'foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd' is not a valid identifier") - >>> _list_of_idents("") + >>> _list_of_idents("foo.3bar, foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd") + (None, "'foo.3bar' is not a valid identifier\\n 'foo3bariendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd' is not a valid identifier") + >>> _list_of_idents("foo.3bar; foo", sep=';') + (None, "'foo.3bar' is not a valid identifier") + >>> _list_of_idents(" ") (None, 'No identifiers found') """ errmsg = None - if entry: - good_list = [x.strip() for x in str(entry).split(sep)] + if entry.strip(): + good_list = [x.strip() for x in entry.split(sep)] for sample in good_list: if _NETCDF_ID_RE.match(sample) is None: if errmsg: @@ -151,27 +167,34 @@ def _is_mult_period(entry): A time-period entry is of the form: [ *] where is an optional integer and is one of the recognized - time period (e.g., steps, days, months). + time periods (e.g., steps, days, months). Also, return an error string or None if no error is found. >>> _is_mult_period("nsteps") ((1, 'nsteps'), None) >>> _is_mult_period("3 * nmonths") ((3, 'nmonths'), None) >>> _is_mult_period("2*fortnights") - (None, 'period must be one of nsteps, nstep, nseconds, nsecond, nminutes, nminute, nhours, nhour, ndays, nday, monthly, nmonths, nmonth, nyears, nyear, steps, seconds, minutes, hours, days, months, years') - >>> _is_mult_period("") - (None, 'no entry for frequency') + (None, 'period must be one of nsteps, nstep, nseconds, nsecond, nminutes, nminute, nhours, nhour, ndays, nday, nmonths, nmonth, nyears, nyear, steps, seconds, minutes, hours, days, months, years') + >>> _is_mult_period("7*nhours of day") + (None, 'period must be one of nsteps, nstep, nseconds, nsecond, nminutes, nminute, nhours, nhour, ndays, nday, nmonths, nmonth, nyears, nyear, steps, seconds, minutes, hours, days, months, years') + >>> _is_mult_period(" ") + (None, 'a frequency ([*]period) is required') >>> _is_mult_period("1*nyear") ((1, 'nyear'), None) >>> _is_mult_period("-6*nhours") (None, 'multiplier must be a positive integer') + >>> _is_mult_period("7h*nhours") + (None, 'multiplier must be a positive integer') + >>> _is_mult_period("5*nhours*ndays") + (None, "Bad formatting of frequency, must be in the form of '*