diff --git a/.gitmodules b/.gitmodules index 21e0eca8..94610494 100644 --- a/.gitmodules +++ b/.gitmodules @@ -3,7 +3,13 @@ url = https://github.com/NCAR/ccpp-framework fxtag = 2024-07-19-dev fxrequired = AlwaysRequired - fxDONOTUSEurl = https://github.com/NCAR/ccpp-framework + fxDONOTUSEurl = https://github.com/NCAR/ccpp-framework +[submodule "history"] + path = src/history/buffers + url = https://github.com/ESMCI/history_output + fxtag = history01_00 + fxrequired = AlwaysRequired + fxDONOTUSEurl = https://github.com/ESMCI/history_output [submodule "mpas"] path = src/dynamics/mpas/dycore url = https://github.com/MPAS-Dev/MPAS-Model.git @@ -13,8 +19,8 @@ fxDONOTUSEurl = https://github.com/MPAS-Dev/MPAS-Model.git [submodule "ncar-physics"] path = src/physics/ncar_ccpp - url = https://github.com/ESCOMP/atmospheric_physics - fxtag = 67bb908e + url = https://github.com/ESCOMP/atmospheric_physics + fxtag = e95c172d7a5a0ebf054f420b08416228e211baa3 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics [submodule "ccs_config"] 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/buildlib b/cime_config/buildlib index 497b4dd5..214e6182 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -97,6 +97,10 @@ def _build_cam(): case.get_value("COMP_INTERFACE")), os.path.join(atm_root, "src", "dynamics", "utils"), os.path.join(atm_root, "src", "physics", "utils"), + os.path.join(atm_root, "src", "history"), + os.path.join(atm_root, "src", "history", "buffers", "src"), + os.path.join(atm_root, "src", "history", "buffers", "src", "hash"), + os.path.join(atm_root, "src", "history", "buffers", "src", "util"), os.path.join(atm_root, "src", "utils")] for path in phys_dirs: if path not in paths: diff --git a/cime_config/buildnml b/cime_config/buildnml index c34bdda1..c00131e3 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 @@ -51,6 +54,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 +301,8 @@ 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) # Check that file actually exists. If not then throw an error: if not os.path.exists(user_nl_file): @@ -362,6 +367,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, logger=_LOGGER) + # 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..1be9ac48 --- /dev/null +++ b/cime_config/hist_config.py @@ -0,0 +1,1108 @@ +""" +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 +import logging +import os +import re +import sys + +# Find and include the ccpp-framework scripts directory +# 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)) +__CCPPSCRIPTS = os.path.join(__CAMROOT, "ccpp_framework", 'scripts') +if __CCPPSCRIPTS not in sys.path: + sys.path.append(__CCPPSCRIPTS) +# end if + +# CCPP framework imports +# pylint: disable=wrong-import-position +from parse_tools import ParseObject, context_string, ParseInternalError +# 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 since midnight GMT in current day, +# %u = unit number (e.g., h0, 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', 'nmonths', 'nmonth', 'nyears', 'nyear', + 'steps', 'seconds', 'minutes', 'hours', + 'days', 'months', 'years'] +_OUT_PRECS = ['REAL32', 'REAL64'] +_TRUE_VALUES = {"true", "t", ".true."} +_FALSE_VALUES = {"false", "f", ".false."} +# NetCDF variable name requirements: +# https://docs.unidata.ucar.edu/netcdf-c/current/programming_notes.html#object_name +_NETCDF_ID_RE = re.compile(r"^[a-z][\w._@+]{0,256}$", re.IGNORECASE) + +############################################################################## +### +### 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().__init__(message) + +############################################################################## +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) + >>> _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 + """ + sline = line.strip() + return not sline or sline.startswith('!') + +############################################################################## +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 = f"{entry} is not an integer" + # 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, 'Found invalid identifiers:\\n foo bar') + >>> _list_of_idents("foo, bAr") + (['foo', 'bAr'], None) + >>> _list_of_idents("foo, BA2r3") + (['foo', 'BA2r3'], None) + >>> _list_of_idents("foo, 3bar") + (None, 'Found invalid identifiers:\\n 3bar') + >>> _list_of_idents("foo,3bar", sep=';') + (None, 'Found invalid identifiers:\\n foo,3bar') + >>> _list_of_idents("foo#3bar, foo3baifijeowfjeiofjewiofjeiwofjewiofejifwjoefdfewfefdfdkjokmcdioanicdiaoilfejieojwiefjidojfioejsiofdjkljnxpoiadjfioenskcodiafkamd199fd9a0fdjkldajfdfjiodanckdalirhgieoskjcdskdfieowfidjfslk129dkjfaiocsriendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd") + (None, 'Found invalid identifiers:\\n foo#3bar\\n foo3baifijeowfjeiofjewiofjeiwofjewiofejifwjoefdfewfefdfdkjokmcdioanicdiaoilfejieojwiefjidojfioejsiofdjkljnxpoiadjfioenskcodiafkamd199fd9a0fdjkldajfdfjiodanckdalirhgieoskjcdskdfieowfidjfslk129dkjfaiocsriendnaadfasdfbasdlkfap983rasdfvalsda938qjnasdasd98adfasxd') + >>> _list_of_idents("foo,3bar; foo", sep=';') + (None, 'Found invalid identifiers:\\n foo,3bar') + >>> _list_of_idents(" ") + (None, 'No identifiers found') + """ + if entry.strip(): + potential_list = [x.strip() for x in entry.split(sep)] + bad_list = [sample for sample in potential_list if _NETCDF_ID_RE.match(sample) is None] + if len(bad_list) > 0: + return (None, "Found invalid identifiers:\n " + "\n ".join(bad_list)) + # end if + return (potential_list, None) + # end if + return (None, "No identifiers found") + +############################################################################## +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 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 ("fortnights") 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 ("nhours of day") 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, 'frequency ([*]period) is required, found " "') + >>> _is_mult_period("1*nyear") + ((1, 'nyear'), None) + >>> _is_mult_period("-6*nhours") + (None, 'multiplier ("-6") must be a positive integer') + >>> _is_mult_period("7h*nhours") + (None, '"7h" in "7h*nhours" is not a valid integer') + >>> _is_mult_period("5*nhours*ndays") + (None, 'frequency must be of the form ([*]period), found "5*nhours*ndays". Do you have too many multipliers or periods?') + """ + if not entry or not entry.strip(): + return (None, f"frequency ([*]period) is required, found \"{entry}\"") + # end if + tokens = [x.strip() for x in entry.split('*')] + num_tokens = len(tokens) + + multiplier = 1 + period = "" + if num_tokens == 1: + period = tokens[0].lower() + elif num_tokens == 2: + multiplier = tokens[0] + period = tokens[1].lower() + else: + return (None, f"frequency must be of the form ([*]period), found \"{entry}\". Do you have too many multipliers or periods?") + # end if + + if period not in _TIME_PERIODS: + time_periods = ", ".join(_TIME_PERIODS) + return (None, f"period (\"{period}\") must be one of {time_periods}") + # end if + (candidate_multiplier, errmsg) = _is_integer(multiplier) + if errmsg: + return (None, f"\"{multiplier}\" in \"{entry}\" is not a valid integer") + # end if + if candidate_multiplier <= 0: + return (None, f"multiplier (\"{candidate_multiplier}\") must be a positive integer") + # end if + + return ((candidate_multiplier, period), None) + +############################################################################## +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 _OUT_PRECS: + ustr = None + out_precs = ", ".join(_OUT_PRECS) + errmsg = f"precision must be one of {out_precs}" + # end if + return ustr, errmsg + +############################################################################## +def _is_string(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). + >>> _is_string(3) + (None, None) + >>> _is_string(3.1) + (None, None) + >>> _is_string('string') + ('string', None) + """ + fval = None + if isinstance(entry, str): + fval = entry.strip() + # 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. + >>> _is_logical('true') + ('true', None) + >>> _is_logical('.false.') + ('.false.', None) + >>> _is_logical('truefalse') + (None, 'hist_write_nstep0 must be one of .false., .true., f, false, t, true') + >>> _is_logical(2) + (None, 'hist_write_nstep0 must be a string, not a int type.') + """ + fval, _ = _is_string(entry) + possible_values = _TRUE_VALUES | _FALSE_VALUES + errmsg = None + if fval is not None: + if fval.lower() not in possible_values: + fval = None + out_values = ", ".join(sorted(possible_values)) + errmsg = f"hist_write_nstep0 must be one of {out_values}" + # end if + else: + errmsg = f"hist_write_nstep0 must be a string, not a {type(entry).__name__} type." + # 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.") + (None, 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) + >>> _parse_hist_config_line(" ") + (None, None, None) + """ + # Find the possible history configuration command for . + if _blank_config_line(line): + return None, None, None + # end if + sline = line.strip() + entry = None + 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: + errmsg = None + else: + cmd = None + errmsg = f"Invalid history config line, '{sline}'" + # end if + return cmd, entry, errmsg + +############################################################################## +class HistFieldList(): +############################################################################## + """Class to store information about a history configuration field list. + """ + + 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 = [] + self.__max_namelen = 0 + + def _add_item(self, item, pobj, logger): + """Add field name, to this object and return True if this + field name was added. + is a single item to be added. + is the ParseObject source of . + """ + if not _is_string(item)[0]: + errmsg = f"Bad diagnostic name, '{item}'" + pobj.add_syntax_err(errmsg) + return False + # end if + if item in self.__field_names: + # Field is a duplicate + ctx = context_string(pobj) + logger.warning(f"Field, '{item}' already in {self.desc} fields for hist volume, {self.volume}{ctx}") + return False + # end if + self.__field_names.append(item) + self.__max_namelen = max(len(item), self.__max_namelen) + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Added {self.desc} field, '{item}' to hist volume, {self.volume}{ctx}") + # end if + return True + + def add_fields(self, items, pobj, logger): + """Add to this object and return True if all items were added. + can be a single item or a list. + is the ParseObject source of + """ + if isinstance(items, list): + do_add = True + for item in items: + do_add &= self._add_item(item, pobj, logger) + # end for + else: + do_add = self._add_item(items, 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) + # end if + # end for + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + for field_name in removed_fields: + errmsg = f"Removed field, '{field_name}' from {self.desc} fields on hist volume, {self.volume}{ctx}" + logger.debug(errmsg) + # end for + # end if + 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 + """ + max_linelen = 120 + if self.__field_names: + lhs = f" {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_namelen + 2 + while line_len < max_linelen: + if fld_end + 1 >= num_fields: + break + # end if + next_len = self.max_namelen + 4 + if (line_len + next_len) > 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 = [f"'{x}{' '*(self.max_namelen - len(x))}'" + for x in self.__field_names[fld_beg:fld_end+1]] + outfile.write(f"{lhs}{', '.join(quotelist)}{comma}\n") + 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_namelen(self): + """Return the length of the longest field in this HistFieldList object. + """ + return self.__max_namelen + + @property + def field_names(self): + """Return the list of field names""" + return self.__field_names + +############################################################################## +### +### History configuration types (for parsing history configuration entries +### +############################################################################## + +############################################################################## +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_0]*") + __HIST_VOL = "(?P(h[0-9]*)|i)" + __HIST_LIST_OF_IDENTIFIERS = "(?P.*)" + __HIST_ASSIGNMENT_OPERATOR = "(:|=)" + __HIST_STATEMENT = rf"\s*(;\s*{__HIST_VOL})?\s*{__HIST_ASSIGNMENT_OPERATOR}\s*{__HIST_LIST_OF_IDENTIFIERS}$" + 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_STATEMENT, + re.IGNORECASE) + self.__entry_check_fn = entry_check_fn + self.__process_fn = process_fn + # Check that name matches pattern + nmatch = self.find_command(self.name) + if (not nmatch) or (nmatch != self.name): + emsg = f"'{self.name}' is not a valid HistConfigEntry name" + raise ValueError(emsg) + # 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) + >>> HistConfigEntry(r"hist_write_nstep0", _list_of_idents, \ + HistoryVolConfig.set_write_nstep0).get_entry("hist_write_nstep0;h3: true") + ((['true'], 'h3'), None) + >>> HistConfigEntry(r"hist_output_frequency", _list_of_idents, \ + HistoryVolConfig.set_output_frequency).get_entry("hist_output_frequency;h2: 5*ndecades") + (None, 'Found invalid identifiers:\\n 5*ndecades') + """ + ematch = self.__entry_regexp.match(line.strip()) + if ematch is None: + return None, f"Invalid {self.name} history config line, '{line.strip()}'" + groups = ematch.groupdict() + vol = groups['vol'] + entry_val, errmsg = self.__entry_check_fn(groups['idents']) + if entry_val: + return (entry_val, vol), errmsg + return None, 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) + __HIST_FILE = "history" + __SAT_FILE = "satellite" + __INITIAL_FILE = "initial_value" + __HFILE_TYPES = [__HIST_FILE, __SAT_FILE, __INITIAL_FILE] + # 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%f.%y-%m-%d-%s.nc' + + def __init__(self, volume): + """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' + self.__precision_set = False + 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.__max_frames_set = False + self.__file_type = self.__HIST_FILE + self.__filename_spec = self._DEFAULT_HISTORY_SPEC + self.__restart_fname_spec = self._DEFAULT_RESTART_HIST_SPEC + self.__restart_fname_spec_set = False + self.__write_nstep0 = ".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. + """ + add_ok = self.__inst_fields.add_fields(fields, pobj, logger) + 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. + """ + add_ok = self.__avg_fields.add_fields(fields, pobj, logger) + 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. + """ + add_ok = self.__min_fields.add_fields(fields, pobj, logger) + 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. + """ + add_ok = self.__max_fields.add_fields(fields, pobj, logger) + 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. + """ + add_ok = self.__var_fields.add_fields(fields, pobj, logger) + return add_ok + + def remove_fields(self, fields, pobj, logger): + """Remove each field in from all lists it is on. + Return True if each field was found (and removed).""" + fields_to_delete = set(fields) + fields_deleted = set() + all_removed = True + for fld_list in self.__all_fields: + removed = fld_list.remove_fields(fields_to_delete, pobj, logger) + fields_deleted.update(removed) + # end for + if fields_to_delete != fields_deleted: + all_removed = False + missing_fields = fields_to_delete.difference(fields_deleted) + ctx = context_string(pobj) + missing_fields_string = ", ".join(missing_fields) + errmsg = f"Cannot remove field(s), '{missing_fields_string}', not found on hist volume, {self.volume}{ctx}" + logger.warning(errmsg) + # end if + return all_removed + + @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""" + precstr, errmsg = _is_prec_str(prec) + if not errmsg: + self.__precision = prec.upper() + self.__precision_set = True + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting precision to '{prec}'{ctx}") + # end if + return True + # end if + emsg = f"Attempt to set unrecognized precision, '{prec}'" + pobj.add_syntax_err(emsg) + return False + + @property + 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 and max_frames is updated.""" + nframes_ok = True + nframes_i, errmsg = _is_integer(nframes) + nframes_ok = not errmsg and (nframes_i > 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(f"Setting max frames to '{nframes}'{ctx}") + # end if + return True + else: + emsg = f"Attempt to set max frames to '{nframes}', must be a positive integer" + pobj.add_syntax_err(emsg) + return False + # end if + + def set_write_nstep0(self, write_nstep0, pobj, logger): + """Modify the write_nstep0 property of this HistoryVolConfig object. + Return True if valid and write_nstep0 updated""" + if write_nstep0.lower() in _TRUE_VALUES: + self.__write_nstep0 = ".true." + elif write_nstep0.lower() in _FALSE_VALUES: + self.__write_nstep0 = ".false." + else: + emsg = f"Attempt to set write_nstep0 to '{write_nstep0}', must be one of {_TRUE_VALUES | _FALSE_VALUES}" + pobj.add_syntax_err(emsg) + return False + # end if + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting write_nstep0 to '{self.__write_nstep0}'{ctx}") + # end if + return True + + def outfreq_str(self): + """Return the output_frequency for this HistoryVolConfig object + as a string""" + return f"{self.__output_freq[0]}*{self.__output_freq[1]}" + + @property + def output_frequency(self): + """Return the output_frequency property for this + HistoryVolConfig object""" + return self.__output_freq + + def __out_frequency_is_valid(this, ofreq): + """ + Determine if a user-supplied output frequency is valid. + Checks: + - frequency is tuple (multiplier, period) + - multiplier is a positive integer + - period is in list of valid time periods + """ + return isinstance(ofreq, tuple) and \ + (len(ofreq) == 2) and \ + (ofreq[0] > 0) and \ + (ofreq[1].strip().lower() in _TIME_PERIODS) + + 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 self.__out_frequency_is_valid(ofreq): + 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 = f"Attempt to set unrecognized output_frequency, '{ofreq}'" + pobj.add_syntax_err(emsg) + 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""" + if ftype.strip().lower() in self.__HFILE_TYPES: + self.__file_type = ftype + else: + tstr = f", must be one of ({', '.join(self.__HFILE_TYPES)})." + pobj.add_syntax_err(f"Bad history file type, '{ftype}'{tstr}") + return False + # 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(f"Setting file type to '{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, logger): + """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'). + """ + 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", + "r%u") + # end if + # end if + if logger.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting filename spec to '{fnspec}'{ctx}") + # end if + + @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, pobj, logger, rfnspec=None): + """Modify the restart 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'). + """ + 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.getEffectiveLevel() <= logging.DEBUG: + ctx = context_string(pobj) + logger.debug(f"Setting restart filename spec to '{rfnspec}'{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() + elif fld_type == 'all': + num_flds = sum([x.num_fields() for x in self.__all_fields]) + else: + raise ParseInternalError(f"Unknown fld_type, '{fld_type}'") + # end if + return num_flds + + 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") + 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(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(f" hist_write_nstep0 = {self.__write_nstep0}\n") + 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_file_type", _is_string, + HistoryVolConfig.set_file_type), + 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_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", + _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 + self.parse_hist_config_file(filename, logger) + # end if (no else, just leave empty dictionary) + + 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", encoding="UTF-8") as cfile: + clines = [line.strip() for line in cfile.readlines()] + # end with + # create a parse object and context for this file + pobj = ParseObject(filename, clines) + curr_line, _ = pobj.curr_line() + while pobj.valid_line(): + args = _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 = 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 = f"volume, '{volume}', not in configs{ctx}" + raise ParseInternalError(emsg) + # 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 = 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 = f"Bad line but no error{ctx}" + raise ParseInternalError(emsg) + # 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 = f"Processing {dfile} for history volume {fnum}" + logger.debug(lmsg) + self.parse_hist_config_file(dfile, logger, volume=fnum) + else: + ctx = context_string(pobj) + emsg = f"History config file, '{cmd_val}', not found{ctx}" + raise HistoryConfigError(emsg) + # end if + else: + hconf_entry = _HIST_CONFIG_ENTRY_OBJS[cmd] + 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, _ = pobj.next_line() + # end while + if pobj.error_message: + # Time to dump out error messages + raise HistoryConfigError(pobj.error_message) + # end if + + 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, default=0) + + 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(f" hist_num_inst_fields = {num_fields}\n") + num_fields = self.max_num_fields('avg') + ofile.write(f" hist_num_avg_fields = {num_fields}\n") + num_fields = self.max_num_fields('min') + ofile.write(f" hist_num_min_fields = {num_fields}\n") + num_fields = self.max_num_fields('max') + ofile.write(f" hist_num_max_fields = {num_fields}\n") + num_fields = self.max_num_fields('var') + ofile.write(f" hist_num_var_fields = {num_fields}\n") + 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_comp.F90 b/src/control/cam_comp.F90 index 0f432c5e..538bd641 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 @@ -89,7 +89,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 @@ -246,9 +246,7 @@ 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 history_init_files(model_doi_url, caseid, ctitle) end subroutine cam_init @@ -410,10 +408,8 @@ subroutine cam_run4(cam_out, cam_in, rstwr, nlend, & ! file output. ! !----------------------------------------------------------------------- -! use cam_history, only: wshist, wrapup ! 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 @@ -424,18 +420,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 wshist() -! call t_stopf('wshist') -!!XXgoldyXX: ^ need to import this - ! ! Write restart files ! @@ -455,30 +439,42 @@ 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 wrapup(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(do_ncdata_check) + subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check, do_history_write) !----------------------------------------------------------------------- ! ! 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 !Flag for whether a snapshot (ncdata) check should be run or not - logical, intent(in) :: do_ncdata_check + ! - flag is true if this is not the first or last step + logical, intent(in) :: do_ncdata_check + !Flag for whether to perform the history write + logical, optional, intent(in) :: do_history_write + + logical :: history_write_loc + + if (present(do_history_write)) then + history_write_loc = do_history_write + else + history_write_loc = .true. + end if + + if (history_write_loc) then + call history_write_files() + end if + ! peverwhee - todo: handle restarts + call history_wrap_up(rstwr, nlend) ! !---------------------------------------------------------- @@ -486,6 +482,7 @@ subroutine cam_timestep_final(do_ncdata_check) !---------------------------------------------------------- ! call phys_timestep_final(do_ncdata_check) + call shr_sys_flush(iulog) end subroutine cam_timestep_final diff --git a/src/control/cam_control_mod.F90 b/src/control/cam_control_mod.F90 index 11057198..4dc86bae 100644 --- a/src/control/cam_control_mod.F90 +++ b/src/control/cam_control_mod.F90 @@ -19,27 +19,16 @@ 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 + 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 :: post_assim ! We are resuming after a pause - 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 :: grayrad_phys ! true => run gray radiation (frierson) physics - logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys - ! or tj2016 or grayrad 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 @@ -123,55 +112,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_1994' - kessler_phys = trim(suite_name) == 'kessler' - tj2016_phys = trim(suite_name) == 'tj2016' - grayrad_phys = trim(suite_name) == 'grayrad' - - simple_phys = adiabatic .or. ideal_phys .or. kessler_phys .or. tj2016_phys .or. grayrad_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)' - else if (grayrad_phys) then - write(iulog,*) 'Run model with Frierson (2006) gray radiation physics' - end if - end if - - end subroutine cam_ctrl_set_physics_type - end module cam_control_mod 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_physics_control.F90 b/src/control/cam_physics_control.F90 new file mode 100644 index 00000000..36c1068f --- /dev/null +++ b/src/control/cam_physics_control.F90 @@ -0,0 +1,85 @@ +module cam_physics_control +!------------------------------------------------------------------------------ +! +! High level physics 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 :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys + ! or tj2016 or grayrad + + +!============================================================================== +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 + logical :: adiabatic + logical :: ideal_phys + logical :: kessler_phys + logical :: tj2016_phys + logical :: grayrad_phys + logical :: moist_physics + + 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_1994' + kessler_phys = trim(suite_name) == 'kessler' + tj2016_phys = trim(suite_name) == 'tj2016' + grayrad_phys = trim(suite_name) == 'grayrad' + + simple_phys = adiabatic .or. ideal_phys .or. kessler_phys .or. tj2016_phys .or. grayrad_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 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)' + else if (grayrad_phys) then + write(iulog,*) 'Run model with Frierson (2006) gray radiation physics' + end if + end if + + end subroutine cam_ctrl_set_physics_type + +end module cam_physics_control 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/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index 7031be1f..7eb79f32 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -32,7 +32,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) ! use physics_grid, only: physics_grid_readnl -! use cam_history, only: history_readnl + use cam_history, only: history_readnl ! use scamMod, only: scam_readnl use physconst, only: physconst_readnl @@ -93,7 +93,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call physconst_readnl(nlfilename) call cam_initfiles_readnl(nlfilename) call cam_constituents_readnl(nlfilename) -! call history_readnl(nlfilename) + call history_readnl(nlfilename) call phys_readnl(nlfilename) ! Should set phys_suite_name call vert_coord_readnl(nlfilename) call ref_pres_readnl(nlfilename) diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 7cdd1247..45fb6ac8 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -61,7 +61,7 @@ module atm_comp_nuopc use cam_control_mod , only : cam_ctrl_set_orbit use cam_pio_utils , only : cam_pio_createfile, cam_pio_openfile, cam_pio_closefile, pio_subsystem use cam_initfiles , only : cam_initfiles_get_caseid, cam_initfiles_get_restdir - use filenames , only : interpret_filename_spec + use cam_filenames , only : interpret_filename_spec use pio , only : file_desc_t, io_desc_t, var_desc_t, pio_double, pio_def_dim, PIO_MAX_NAME use pio , only : pio_closefile, pio_put_att, pio_enddef, pio_nowrite use pio , only : pio_inq_dimid, pio_inq_varid, pio_inquire_dimension, pio_def_var @@ -69,6 +69,7 @@ module atm_comp_nuopc use pio , only : pio_read_darray, pio_write_darray use pio , only : pio_noerr, pio_bcast_error, pio_internal_error, pio_seterrorhandling use pio , only : pio_def_var, pio_get_var, pio_put_var, PIO_INT + use cam_history_support , only : fillvalue use ioFileMod , only : cam_get_file !$use omp_lib , only : omp_set_num_threads @@ -129,9 +130,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), parameter :: fillvalue = 1.e36_r8 - real(R8) , parameter :: grid_tol = 1.e-2_r8 ! tolerance for calculated lat/lon vs read in type(ESMF_Mesh) :: model_mesh ! model_mesh @@ -1169,7 +1167,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(do_ncdata_check=do_ncdata_check) + call cam_timestep_final(rstwr, nlend, do_ncdata_check=do_ncdata_check) ! Advance cam time step @@ -1395,6 +1393,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) ' @@ -1406,10 +1415,44 @@ subroutine ModelFinalize(gcomp, rc) rc = ESMF_SUCCESS - call shr_log_getLogUnit(shrlogunit) - call shr_log_setLogUnit(iulog) + 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 + if (ChkErr(rc,__LINE__,u_FILE_u)) return + rstwr = .false. + endif + + ! Determine if time to stop + + call ESMF_ClockGetAlarm(clock, alarmname='alarm_stop', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + nlend = .true. + else + if (ChkErr(rc,__LINE__,u_FILE_u)) return + nlend = .false. + endif - call cam_timestep_final(do_ncdata_check=.false.) + call cam_timestep_final(rstwr, nlend, do_ncdata_check=.false., do_history_write=.false.) call cam_final(cam_out, cam_in) if (masterproc) then diff --git a/src/data/registry.xml b/src/data/registry.xml index ef2abbc2..41b31416 100644 --- a/src/data/registry.xml +++ b/src/data/registry.xml @@ -149,7 +149,7 @@ horizontal_dimension vertical_layer_dimension lnpmiddry state_lnpmiddry - inverse exner function w.r.t. surface pressure (ps/p)^(R/cp) @@ -311,11 +311,9 @@ surface_geopotential geopotential_height_wrt_surface geopotential_height_wrt_surface_at_interface - inverse_exner_function_wrt_surface_pressure + reciprocal_of_dimensionless_exner_function_wrt_surface_air_pressure frontogenesis_function frontogenesis_angle - vertically_integrated_total_energy_of_initial_state_using_physics_energy_formula - vertically_integrated_total_energy_of_current_state_using_physics_energy_formula vertically_integrated_total_energy_of_initial_state_using_dycore_energy_formula vertically_integrated_total_energy_of_current_state_using_dycore_energy_formula vertically_integrated_water_vapor_and_condensed_water_of_initial_state @@ -423,24 +421,28 @@ 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/dynamics/mpas/dyn_comp.F90 b/src/dynamics/mpas/dyn_comp.F90 index 5c2d8f0b..30e4b2a5 100644 --- a/src/dynamics/mpas/dyn_comp.F90 +++ b/src/dynamics/mpas/dyn_comp.F90 @@ -812,7 +812,7 @@ subroutine mark_variable_as_initialized() call mark_as_initialized('eastward_wind') call mark_as_initialized('geopotential_height_wrt_surface') call mark_as_initialized('geopotential_height_wrt_surface_at_interface') - call mark_as_initialized('inverse_exner_function_wrt_surface_pressure') + call mark_as_initialized('reciprocal_of_dimensionless_exner_function_wrt_surface_air_pressure') call mark_as_initialized('lagrangian_tendency_of_air_pressure') call mark_as_initialized('ln_air_pressure') call mark_as_initialized('ln_air_pressure_at_interface') diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 8d74b66e..ab52d91c 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 @@ -1846,7 +1847,7 @@ subroutine read_inidat(dyn_in) call mark_as_initialized("ln_air_pressure_of_dry_air") call mark_as_initialized("reciprocal_of_air_pressure_thickness_of_dry_air") call mark_as_initialized("reciprocal_of_air_pressure_thickness") - call mark_as_initialized("inverse_exner_function_wrt_surface_pressure") + call mark_as_initialized("reciprocal_of_dimensionless_exner_function_wrt_surface_air_pressure") call mark_as_initialized("lagrangian_tendency_of_air_pressure") call mark_as_initialized("tendency_of_air_temperature_due_to_model_physics") call mark_as_initialized("tendency_of_eastward_wind_due_to_model_physics") diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90 index 59777ef2..a355cca0 100644 --- a/src/dynamics/utils/hycoef.F90 +++ b/src/dynamics/utils/hycoef.F90 @@ -56,7 +56,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 use phys_vars_init_check, only: mark_as_initialized @@ -96,7 +96,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' @@ -255,65 +255,65 @@ 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, & + standard_name='atmosphere_hybrid_sigma_pressure_coordinate', & + 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', & + standard_name='atmosphere_hybrid_sigma_pressure_coordinate_at_interfaces') + 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_at_interfaces', & + formula_terms=formula_terms) + end if + if (masterproc) then write(iulog,'(a)')' Layer Locations (*1000) ' do k=1,pver diff --git a/src/history/buffers b/src/history/buffers new file mode 160000 index 00000000..f59357ea --- /dev/null +++ b/src/history/buffers @@ -0,0 +1 @@ +Subproject commit f59357ea6d96cfe949ba5b08995a48dff4b1b987 diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90 new file mode 100644 index 00000000..525440a1 --- /dev/null +++ b/src/history/cam_hist_file.F90 @@ -0,0 +1,2104 @@ +module cam_hist_file + ! Module to define and read CAM history configuration namelist entries + ! and associated history files + + use ISO_FORTRAN_ENV, only: REAL64 + use pio, only: file_desc_t, var_desc_t + 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 + use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL + use hist_field, only: hist_field_info_t + use hist_hash_table, only: hist_hash_table_t + use cam_grid_support, only: max_split_files + use runtime_obj, only: UNSET_I => unset_int + use runtime_obj, only: UNSET_C => unset_str + use runtime_obj, only: UNSET_R8 => unset_real + + 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 + + logical, parameter :: PATCH_DEF = .true. + integer, parameter :: OUTPUT_DEF = REAL64 + integer, parameter :: vlen = 8 + integer, parameter :: flen = 16 + integer, parameter :: tlen = 16 + + integer, parameter :: hfile_type_default = -1 + integer, parameter :: hfile_type_history = 1 + integer, parameter :: hfile_type_init_value = 2 + integer, parameter :: hfile_type_sat_track = 3 + integer, parameter :: hfile_type_restart = 4 + + 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(r8), private :: beg_time = UNSET_R8 + real(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(:) + 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 + 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 + 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 :: tsecid + type(var_desc_t), private :: nstephid + + + ! Field list + 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_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 + 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 :: 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 + procedure :: print_config => config_print_config + 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 + 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 + private :: read_namelist_entry ! Read a namelist group and create config + +CONTAINS + + ! ======================================================================== + + function config_filename(this) result(cfiles) + 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, ierr + character(len=*), parameter :: subname = 'config_filename: ' + + accum_types(instantaneous_file_index) = 'i' + accum_types(accumulated_file_index) = 'a' + allocate(cfiles(max_split_files), stat=ierr) + call check_allocate(ierr, subname, 'cfiles', & + file=__FILE__, line=__LINE__-1) + + do file_idx = 1, size(cfiles) + 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 + 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, ierr + character(len=*), parameter :: subname = 'config_set_filenames: ' + + if (allocated(this%file_names)) then + return + end if + 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) + 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 + + ! ======================================================================== + + 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 + + ! ======================================================================== + + pure 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 + + ! ======================================================================== + + pure function config_get_filename_spec(this) result(filename_spec) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + character(len=:), allocatable :: filename_spec + + filename_spec = this%filename_spec + + end function config_get_filename_spec + + ! ======================================================================== + + pure function config_get_last_month_written(this) result(last_month_written) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + integer :: last_month_written + + last_month_written = this%last_month_written + + end function config_get_last_month_written + + ! ======================================================================== + + pure function config_get_last_year_written(this) result(last_year_written) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + integer :: last_year_written + + last_year_written = this%last_year_written + + end function config_get_last_year_written + + ! ======================================================================== + + pure function config_precision(this) result(cprec) + use ISO_FORTRAN_ENV, only: REAL32 + ! Dummy arguments + class(hist_file_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 + + ! ======================================================================== + + pure function config_volume(this) result(cvol) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + character(len=vlen) :: cvol + + cvol = this%volume + + end function config_volume + + ! ======================================================================== + + pure function config_max_frame(this) result(max_frame) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + integer :: max_frame + + max_frame = this%max_frames + end function config_max_frame + + ! ======================================================================== + + pure function config_get_num_samples(this) result(num_samples) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + integer :: num_samples + + num_samples = this%num_samples + end function config_get_num_samples + + ! ======================================================================== + + pure function config_get_beg_time(this) result(beg_time) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + real(r8) :: beg_time + + beg_time = this%beg_time + end function config_get_beg_time + + ! ======================================================================== + + function config_output_freq(this) result(out_freq) + 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 + 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 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 + + ! ======================================================================== + + subroutine config_output_freq_separate(this, out_freq_mult, out_freq_type) + 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 + + ! ======================================================================== + + pure function config_history_file(this) result(history_file) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: history_file + + history_file = this%hfile_type == hfile_type_history + + end function config_history_file + + ! ======================================================================== + + pure function config_init_value_file(this) result(init_value_file) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: init_value_file + + init_value_file = this%hfile_type == hfile_type_init_value + + end function config_init_value_file + + ! ======================================================================== + + pure function config_satellite_file(this) result(satellite_file) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: satellite_file + + satellite_file = this%hfile_type == hfile_type_sat_track + + end function config_satellite_file + + ! ======================================================================== + + pure function config_restart_file(this) result(restart_file) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: restart_file + + restart_file = this%hfile_type == hfile_type_restart + + end function config_restart_file + + ! ======================================================================== + + pure function config_do_write_nstep0(this) result(write_nstep0) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: write_nstep0 + + write_nstep0 = this%write_nstep0 + + end function config_do_write_nstep0 + + ! ======================================================================== + + pure function config_file_is_setup(this) result(file_is_setup) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: file_is_setup + + file_is_setup = allocated(this%grids) + + end function config_file_is_setup + + ! ======================================================================== + + pure function config_files_open(this) result(files_open) + ! Dummy arguments + class(hist_file_t), intent(in) :: this + logical :: files_open + + files_open = this%files_open + + end function config_files_open + + ! ======================================================================== + + subroutine config_reset(this) + ! Dummy argument + class(hist_file_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%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 + 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, 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) + use shr_string_mod, only: to_lower => shr_string_toLower + use cam_history_support, only: parse_multiplier + use cam_abortutils, only: endrun, check_allocate + use shr_kind_mod, only: CM => shr_kind_cm + use time_manager, only: get_step_size + use string_utils, only: stringify + ! Dummy arguments + class(hist_file_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 + 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 + ! Local variables + character(len=CM) :: 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 + integer :: dtime + integer :: freq_in_seconds + integer :: filename_len + character(len=*), parameter :: freq_types_to_check(3) = (/'second', 'minute', 'hour '/) + integer, parameter :: seconds_in_minute = 60 + integer, parameter :: seconds_in_hour = 3600 + character(len=*), parameter :: subname = 'config_configure: ' + character(len=*), parameter :: default_filename_spec = '%c.cam.%u%f.%y-%m-%d-%s.nc' + + call this%reset() + + this%volume = volume + this%rl_kind = out_prec + this%max_frames = max_frames + dtime = get_step_size() + ! 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 ', 'nmonths ', 'nmonth ', 'nyears ', 'nyear ', & + 'steps ', 'seconds ', 'minutes ', 'hours ', '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 + ! 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 + ! It's an error to have a frequency < the timestep size + if (any(freq_types_to_check == trim(this%output_freq_type))) then + freq_in_seconds = this%output_freq_mult + if (trim(this%output_freq_type) == 'hour') then + freq_in_seconds = this%output_freq_mult * seconds_in_hour + else if (trim(this%output_freq_type) == 'minute') then + freq_in_seconds = this%output_freq_mult * seconds_in_minute + end if + if (freq_in_seconds < dtime) then + write(errmsg,*) subname//' ERROR: output frequency "', trim(output_freq), & + '" cannot be less than timestep size (', stringify((/dtime/)), & + ' seconds)' + call endrun(errmsg, file=__FILE__) + end if + end if + + this%hfile_type = file_type + this%collect_patch_output = collect_patch_out + this%write_nstep0 = write_nstep0 + ! Append accumulation flag to user-specified filename specifier + if (trim(filename_spec) /= default_filename_spec) then + filename_len = len_trim(filename_spec) + this%filename_spec = filename_spec(:filename_len-3) // '%f.nc' + else + this%filename_spec = filename_spec + end if + + 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 + + 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 + + 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, 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, 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, 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, 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, num_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: stringify + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use ISO_FORTRAN_ENV,only: REAL32 + ! Dummy argument + class(hist_file_t), intent(in) :: this + + if (masterproc) then + 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) + 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, "// & + stringify((/this%hfile_type/))) + end select + if (this%rl_kind == REAL64) then + write(iulog, '(a)') " Output precision, 64 bits" + else if (this%rl_kind == REAL32) then + write(iulog, '(a)') " Output precision, 32 bits" + else + call endrun("ERROR: Unknown output precision, "// & + stringify((/this%rl_kind/))) + end if + write(iulog, '(a,i0)') " Maximum number of output frames per file = ", & + this%max_frames + if (this%output_freq_mult == 1) then + write(iulog, *) " Writing output once per ", trim(this%output_freq_type) + else + 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(iulog, '(2a)') " Output from all patches will be collected ", & + "into a single variable" + else + write(iulog, '(2a)') " Output from each patch will be written ", & + "as a separate variable" + end if + ! peverwhee - add interpolation info + end if + end subroutine config_print_config + + ! ======================================================================== + + 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 + integer, parameter :: seconds_per_day = 86400._r8 + + this%beg_time = day + (sec/seconds_per_day) + + 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 hist_hashable, only: hist_hashable_t + use cam_grid_support, only: cam_grid_num_grids + 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 + use cam_abortutils, only: check_allocate, endrun + use shr_kind_mod, only: CM => shr_kind_cm + + ! 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_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_hashable_t), pointer :: field_ptr_entry + character(len=*), parameter :: subname = 'hist:config_set_up_fields: ' + integer, allocatable :: dimensions(:) + integer, allocatable :: field_shape(:) + integer, allocatable :: beg_dim(:) + integer, allocatable :: end_dim(:) + character(len=CM) :: 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) + 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)) + select type(field_ptr_entry) + type is (hist_field_info_t) + field_ptr => field_ptr_entry + class default + write(errmsg,'(3a)') 'ERROR Field : ',trim(this%field_names(idx)),' not available' + call endrun(subname//errmsg, file=__FILE__, line=__LINE__) + end select + !call field_ptr%dimensions(dimensions) + dimensions = field_ptr%dimensions() + field_shape = field_ptr%shape() + beg_dim = field_ptr%beg_dims() + end_dim = field_ptr%end_dims() + 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, & + 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 + call errors%output(iulog) + end if + ! 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%field_list_hash_table%add_hash_key(field_info) + ! Add grid to possible grids if it's not already there + if (.not. any(possible_grids(:) == field_ptr%decomp())) then + grid_idx = findloc(possible_grids(:), -1, dim=1) + possible_grids(grid_idx) = field_ptr%decomp() + num_grids = num_grids + 1 + end if + 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), stat=ierr) + call check_allocate(ierr, subname, 'this%grids', & + file=__FILE__, line=__LINE__-1) + this%grids(1:num_grids) = possible_grids(1:num_grids) + ! We don't need the user-set fields arrays anymore + deallocate(this%accumulate_types) + deallocate(this%field_names) + + 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 + class(hist_field_info_t), pointer, intent(out) :: field_info + character(len=*), intent(out) :: errmsg + + ! Local variables + class(hist_hashable_t), pointer :: field_ptr_entry + integer :: field_idx + logical :: found_field + character(len=*), parameter :: subname = 'hist:find_in_field_list: ' + + nullify(field_info) + errmsg = '' + found_field = .false. + ! Loop over fields + do field_idx = 1, size(this%field_list) + if (trim(this%field_list(field_idx)%diag_name()) == trim(diagnostic_name)) then + ! Grab the associated accumulate flag + found_field = .true. + end if + end do + if (.not. found_field) then + ! Not an error - return with the null field_info pointer + 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 + write(errmsg,*) subname//'Unknown field type for "'//trim(diagnostic_name)//'"' + 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) + 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) + + ! 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(:) = 'mean (over local time)' + 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 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, stringify + use cam_control_mod, only: caseid + use cam_initfiles, only: ncdata, bnd_topo + use cam_abortutils, only: check_allocate, endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + use shr_kind_mod, only: CM => shr_kind_cm + ! 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(:) + + 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=CM) :: 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 :: max_mdims ! maximum number of middle dimensions + integer :: max_hdims ! maximum number of grid dimensions + + integer, allocatable :: dimindex(:) ! 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(:) + integer, parameter :: max_netcdf_len = 256 + character(len=*), parameter :: subname = 'config_define_file: ' + + is_initfile = (this%hfile_type == hfile_type_init_value) + is_satfile = (this%hfile_type == hfile_type_sat_track) + + ! Log what we're doing + if (masterproc) then + 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 + + 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%has_accumulated) then + call cam_pio_createfile(this%hist_files(accumulated_file_index), & + this%file_names(accumulated_file_index), amode) + end if + + this%files_open = .true. + + allocate(header_info(size(this%grids)), stat=ierr) + call check_allocate(ierr, subname, 'header_info', & + file=__FILE__, line=__LINE__-1) + + max_hdims = 0 + do grid_index = 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_attr(this%hist_files(split_file_index), & + this%grids(grid_index), header_info(grid_index), & + file_index=split_file_index) + max_hdims = max(max_hdims, header_info(grid_index)%num_hdims()) + end if + end do + end do + ! Determine the maximum number of dimensions + do field_index = 1, size(this%field_list) + max_mdims = max(max_mdims, size(this%field_list(field_index)%dimensions())) + end do + ! Allocate dimindex to the maximum possible dimensions (plus 1 for time) + allocate(dimindex(max_hdims + max_mdims + 1), stat=ierr) + call check_allocate(ierr, subname, 'dimindex', file=__FILE__, line=__LINE__-1) + + 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 + 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) + + do split_file_index = 1, max_split_files + if (.not. pio_file_is_open(this%hist_files(split_file_index))) then + cycle + end if + ! Define the unlimited time dim + 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) + ! 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) + 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) + 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-SIMA') + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "source" attribute to file') + 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',trim(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', trim(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 + ! + 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') + + 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)) + call cam_pio_handle_error(ierr, 'config_define_file: failed to add "long_name" attribute to "nscur" variable') + 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 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! 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%precision() == 'REAL32') then + ncreal = pio_real + else if (this%precision() == 'REAL64') then + ncreal = pio_double + end if + mdims = this%field_list(field_index)%dimensions() + mdimsize = size(mdims) + fname_tmp = strip_suffix(this%field_list(field_index)%diag_name()) + ! Ensure that fname_tmp is not longer than the maximum length for a + ! netcdf file + if (len_trim(fname_tmp) > max_netcdf_len) then + ! Endrun if the name is too long + write(errmsg, *) 'config_define_file: variable name ', trim(fname_tmp), & + ' too long for NetCDF file (len=', stringify((/len(trim(fname_tmp))/)), ' > ', & + stringify((/max_netcdf_len/)), ')' + call endrun(errmsg, file=__FILE__, line=__LINE__) + end if + ! + ! Create variables and atributes for fields written out as columns + ! + ! Find appropriate grid in header_info + if (.not. allocated(header_info)) then + ! Safety check + call endrun('config_define_file: header_info not allocated', file=__FILE__, line=__LINE__) + 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, file=__FILE__, line=__LINE__) + end if + num_hdims = header_info(grd)%num_hdims() + do idx = 1, num_hdims + dimindex(idx) = header_info(grd)%get_hdimid(idx) + nacsdims(idx) = header_info(grd)%get_hdimid(idx) + end do + do idx = 1, num_patches + varid = this%file_varids(field_index, idx) + ! Figure the dimension ID array for this field + ! We have defined the horizontal grid dimensions in dimindex + fdims = num_hdims + do jdx = 1, mdimsize + fdims = fdims + 1 + dimindex(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 + dimindex(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, & + dimindex(1:fdims), varid) + if (.not. varid_set) then + 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)) + 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!', file=__FILE__, line=__LINE__) + 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(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) + 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 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', file=__FILE__, line=__LINE__) + end if + if(masterproc) then + write(iulog,*)'config_define_file: Successfully opened netcdf file '//trim(this%file_names(split_file_index)) + end if + + ! + ! Write time-invariant portion of history header + + if (.not. is_satfile) then + do idx = 1, size(this%grids) + call cam_grid_write_var(this%hist_files(split_file_index), this%grids(idx), & + file_index=split_file_index) + end do + 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') + 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 if + + ! Write the mdim variable data + call write_hist_coord_vars(this%hist_files(split_file_index), restart) + + end do ! end loop over files + + if (allocated(header_info)) then + do idx = 1, size(header_info) + call header_info(idx)%deallocate() + end do + deallocate(header_info) + end if + + end subroutine config_define_file + + ! ======================================================================== + + 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 + use datetime_mod, only: datetime + 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 + 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 :: 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) + 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 + + ! Increment samples + this%num_samples = this%num_samples + 1 + + start = mod(this%num_samples, this%max_frames) + 1 + count1 = 1 + + is_initfile = (this%hfile_type == hfile_type_init_value) + is_satfile = (this%hfile_type == hfile_type_sat_track) + + startc(1) = 1 + startc(2) = start + countc(2) = 1 + + if(.not.restart) this%beg_time = time ! update beginning time of next interval + call datetime (cdate, ctime) + + ! peverwhee - TODO handle composed fields + + call t_startf ('write_field') + 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 (masterproc) then + if (split_file_index == instantaneous_file_index) then + write(iulog,200) this%num_samples,'instantaneous',trim(this%volume),yr,mon,day,ncsec(split_file_index) + else + write(iulog,200) this%num_samples,'accumulated',trim(this%volume),yr_mid,mon_mid,day_mid,ncsec(split_file_index) + end if +200 format('config_write_*: writing time sample ',i3,' to ', a, ' h-file ', & + a,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6) + end if + if (split_file_index == instantaneous_file_index) then + ierr = pio_put_var (this%hist_files(split_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(split_file_index),this%nscurid,(/start/),(/count1/),(/nscur/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "nscur" variable') + ierr = pio_put_var (this%hist_files(split_file_index),this%nstephid,(/start/),(/count1/),(/nstep/)) + call cam_pio_handle_error(ierr, 'config_write_time_dependent_variables: cannot write "nstephid" variable') + end if + 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') + countc(1) = 2 + 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/)) + 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') + countc(1) = 8 + 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') + do field_idx = 1, size(this%field_list) + ! 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(this%field_list(field_idx), split_file_index, restart, start, field_idx) + end do + end do + call t_stopf ('write_field') + + end subroutine config_write_time_dependent_variables + + ! ======================================================================== + + subroutine config_write_field(this, field, split_file_index, restart, & + sample_index, field_index) + use pio, only: PIO_OFFSET_KIND, pio_setframe + 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, endrun + use hist_field, only: hist_field_info_t + ! Dummy arguments + class(hist_file_t), intent(inout) :: this + type(hist_field_info_t), intent(inout) :: field + 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 + integer :: frank ! Field file rank + integer :: field_shape_temp + integer, allocatable :: dimind(:) + integer, allocatable :: dim_sizes(:) + integer, allocatable :: beg_dims(:) + integer, allocatable :: end_dims(:) + integer :: patch_idx, num_patches, ierr + type(var_desc_t) :: varid + integer :: field_decomp + integer :: idx + real(r8), allocatable :: field_data(:,:) + class(hist_buffer_t), pointer :: buff_ptr + character(len=*), parameter :: subname = 'config_write_field: ' + + !!! Get the field's shape and decomposition + ! Shape on disk + field_shape = field%shape() + beg_dims = field%beg_dims() + end_dims = field%end_dims() + frank = size(field_shape) + if (frank == 1) then + 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(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 + dimind = field%dimensions() + + 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 + field_decomp = field%decomp() + + num_patches = 1 + + do patch_idx = 1, num_patches + 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 + 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 + + ! ======================================================================== + + 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 + + ! Local variables + integer :: split_file_index + + if(pio_file_is_open(this%hist_files(accumulated_file_index)) .or. & + pio_file_is_open(this%hist_files(instantaneous_file_index))) then + deallocate(this%file_varids) + end if + + do split_file_index = 1, max_split_files + if (pio_file_is_open(this%hist_files(split_file_index))) then + if (masterproc) then + write(iulog,*)'config_close_files: nf_close(', trim(this%volume),')=',& + this%file_names(split_file_index) + end if + call cam_pio_closefile(this%hist_files(split_file_index)) + end if + end do + + if (allocated(this%file_names)) then + deallocate(this%file_names) + end if + this%files_open = .false. + + 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 + + ! ======================================================================== + + pure function count_array(arr_in) result(arr_count) + ! Dummy arguments + character(len=*), intent(in) :: arr_in(:) + integer :: arr_count + ! Local variable + integer :: index + + arr_count = 0 + do index = 1, size(arr_in) + if (len_trim(arr_in(index)) > 0) then + arr_count = arr_count + 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: stringify + use spmd_utils, only: masterproc, masterprocid, mpicom + use shr_nl_mod, only: shr_nl_find_group_name + use cam_abortutils, only: endrun + use shr_kind_mod, only: CM => shr_kind_cm + use ISO_FORTRAN_ENV,only: REAL32 + ! 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_t), intent(inout) :: hfile_config + 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 + 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 + character(len=CL) :: hist_filename_spec + logical :: hist_write_nstep0 + ! Local variables (other) + integer :: ierr + character(len=CM) :: errmsg + 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 + ! 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, hist_filename_spec, & + hist_write_nstep0 + + ! 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 + 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 + file_type = hfile_type_default + hist_filename_spec = UNSET_C + hist_write_nstep0 = .false. + + ! Read namelist entry + if (masterproc) then + read(unitn, hist_file_config_nl, iostat=ierr, iomsg=errmsg) + if (ierr /= 0) then + call endrun(subname//"ERROR "//trim(errmsg)//' (code= '//trim(stringify((/ierr/)))// & + ") reading namelist", file=__FILE__, line=__LINE__) + end if + ! Translate + select case(trim(hist_file_type)) + case(UNSET_C, 'history') + file_type = hfile_type_history + case('initial_value') + 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__) + end select + ! Translate precision into rl_kind + rl_kind = UNSET_I + select case(trim(hist_precision)) + case('REAL32') + rl_kind = REAL32 + case('REAL64') + rl_kind = REAL64 + case default + 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 + if (num_fields_inst > 0) then + 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(:), 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(:), 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(:), 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(:), max_fldlen*num_fields_var, 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(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) + 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, 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, & + 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 + + ! ======================================================================== + + 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_nl_mod, only: shr_nl_find_group_name + use cam_logfile, only: iulog + use spmd_utils, only: mpicom, masterproc, masterprocid + use cam_abortutils, only: check_allocate, endrun + use shr_kind_mod, only: CM => shr_kind_cm + ! 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=CM) :: errmsg + character(len=CM) :: io_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, iomsg=io_errmsg) + if (ierr /= 0) then + write(errmsg, '(2a,i0,4a)') subname, ": ERROR ", ierr, & + " reading namelist, hist_config_arrays_nl", & + " (error message= '", trim(io_errmsg), "')" + call endrun(trim(errmsg)) + end if + else + write(iulog, *) 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', & + 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', & + 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', & + 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', & + 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', & + file=__FILE__, line=__LINE__-1) + + 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, CM => shr_kind_cm + use shr_nl_mod, only: shr_nl_find_group_name + use spmd_utils, only: masterproc, masterprocid, mpicom + 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 + ! broadcast to other tasks. + + ! Dummy arguments + character(len=*), intent(in) :: filename + type(hist_file_t), allocatable, intent(inout) :: 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=CM) :: errmsg + character(len=CM) :: io_errmsg + character(len=*), parameter :: subname = 'read_config_file' + + ! 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) + if (.not. filefound) then + write(config_line, *) & + ": ERROR: could not find history config file '", & + trim(filename), "'" + call endrun(subname//trim(config_line)) + else + open(newunit=unitn, file=trim(filename), status='old', iostat=ierr) + if (ierr /= 0) then + write(errmsg, '(a,i0,2a)') ": Error ", ierr, " opening ", & + trim(filename) + end if + line_num = 0 + end if + 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 + ! 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, iomsg=io_errmsg) config_line + ! Check that the read did not cause trouble + if (read_status > 0) then + write(errmsg, '(a,i0,5a)') ": Error (", read_status, & + " - '", trim(io_errmsg), "') from '", trim(filename), "'" + close(unitn) + call endrun(subname//trim(errmsg)) + 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', & + file=__FILE__, line=__LINE__-1) + ! 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)) + 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 subroutine hist_read_namelist_config + + pure function strip_suffix(name) result(stripped) + use cam_history_support, only: fieldname_len + ! + !---------------------------------------------------------- + ! + ! Purpose: Strip "&IC" suffix from fieldnames if it exists + ! + !---------------------------------------------------------- + ! + ! Arguments + ! + character(len=*), intent(in) :: name + character(len=max_fldlen) :: stripped + ! + ! Local workspace + ! + integer :: n + ! + !----------------------------------------------------------------------- + ! + stripped = ' ' + + do n = 1,fieldname_len + stripped(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 + + stripped(fieldname_len+1:max_fldlen) = name(fieldname_len+1:max_fldlen) + + end function strip_suffix + + !####################################################################### + +end module cam_hist_file diff --git a/src/history/cam_history.F90 b/src/history/cam_history.F90 new file mode 100644 index 00000000..7823ed23 --- /dev/null +++ b/src/history/cam_history.F90 @@ -0,0 +1,868 @@ +module cam_history + !---------------------------------------------------------------------------- + ! + ! The cam_history module provides the user interface for CAM's history + ! output capabilities. + ! + ! 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 + use cam_hist_file, only: hist_file_t + use hist_field, only: hist_field_info_t + use hist_hash_table, only: hist_hash_table_t + + implicit none + private + save + + character(len=cl) :: model_doi_url = '' ! Model DOI + character(len=cl) :: caseid = '' ! case ID + character(len=cl) :: ctitle = '' ! case title + character(len=32) :: logname ! user name + character(len=32) :: host ! host name + + ! Functions + public :: history_readnl ! Namelist reader for CAM history + 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 + + 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), 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 + + subroutine history_readnl(nlfile) + !----------------------------------------------------------------------- + ! + ! Purpose: Read in history namelist and set hist_configs + ! + !----------------------------------------------------------------------- + use cam_hist_file, only: hist_read_namelist_config + + ! Dummy argument + character(len=*), intent(in) :: nlfile ! path of namelist input file + + ! Read in CAM history configuration + call hist_read_namelist_config(nlfile, hist_configs) + + 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: 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 + 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 + integer :: nstep, dtime, nstep_freq + integer :: ncsec + integer :: num_samples + 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 + character(len=cl) :: filename_spec, prev_filename_spec + 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') + if (mod(nstep, out_frq_mult) == 0) then + write_history = .true. + end if + case('second') + nstep_freq = out_frq_mult / dtime + if (mod(nstep, nstep_freq) == 0) then + write_history = .true. + end if + case('minute') + nstep_freq = nint((out_frq_mult * 60._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then + write_history = .true. + end if + case('hour') + nstep_freq = nint((out_frq_mult * 3600._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then + write_history = .true. + end if + case('day') + nstep_freq = nint((out_frq_mult * 86400._r8) / dtime) + if (mod(nstep, nstep_freq) == 0) then + write_history = .true. + end if + case('month') + ! 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') + ! 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 (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! + 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 is the first write to this file - set up volume + call hist_configs(file_idx)%set_filenames() + file_names = hist_configs(file_idx)%get_filenames() + 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 + filename_spec = hist_configs(file_idx)%get_filename_spec() + prev_filename_spec = hist_configs(prev_file_idx)%get_filename_spec() + if (masterproc) then + write(iulog,*)'history_write_files: New filename same as old file = ', trim(file_names(idx)) + 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('history_write_files: ERROR - duplicate history file name', file=__FILE__, line=__LINE__) + end if + end do + end do + call hist_configs(file_idx)%define_file(restart, logname, host, model_doi_url) + end if + call hist_configs(file_idx)%write_time_dependent_variables(restart) + end do + + end subroutine history_write_files + + !=========================================================================== + + subroutine history_init_files(model_doi_url_in, caseid_in, ctitle_in) + + !----------------------------------------------------------------------- + ! + ! 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 spmd_utils, only: mpicom, masterprocid, masterproc + use mpi, only: mpi_character + use cam_abortutils, only: endrun + use string_utils, only: stringify + use cam_logfile, only: iulog + ! + !----------------------------------------------------------------------- + ! + ! 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_idx ! file, field indices + integer :: day, sec ! day and seconds from base date + integer :: rcode ! shr_sys_getenv return code + character(len=*), parameter :: subname = 'history_init_files: ' + + ! + ! 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) + if (rcode == -1) then + write(iulog,*) subname//'WARNING: user logname has been truncated to '//stringify((/len(logname)/))//' characters' + else if (rcode == 1) then + write(iulog,*) subname//'WARNING: user logname not found; defaulting to empty string' + logname = ' ' + end if + host = ' ' + call shr_sys_getenv ('HOST', host, rcode) + if (rcode == -1) then + write(iulog,*) subname//'WARNING: machine host name has been truncated to '//stringify((/len(host)/))//' characters' + else if (rcode == 1) then + write(iulog,*) subname//'WARNING: machine host name not found; defaulting to empty string' + host = ' ' + end if + 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) + + call get_curr_time(day, sec) ! elapased time since reference date + + ! Set up hist fields on each user-specified file + do file_idx = 1, size(hist_configs) + ! Time at beginning of current averaging interval. + call hist_configs(file_idx)%set_beg_time(day, sec) + + ! Set up fields and buffers + call hist_configs(file_idx)%set_up_fields(possible_field_list) + end do + + ! Deallocate the possible field list hash table + call possible_field_list%deallocate_table() + + + 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 + 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 ******************' + do + if (associated(field_ptr)) then + avgflag = field_ptr%accumulate_type() + if (avgflag == 'lst') then + avgflag = 'inst' + end if + 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) + field_ptr => field_ptr%next + else + exit + end if + end do + write(iulog,*)' *************** END HISTORY FIELD LIST ****************' + write(iulog,*) ' ' + end if + + 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 + + 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, flag_xyfill, mixing_ratio) + use cam_history_support, only: get_hist_coord_index, max_chars, horiz_only + use cam_abortutils, only: endrun, check_allocate + !----------------------------------------------------------------------- + ! + ! Purpose: Add a field to the master field list + ! + ! 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). + ! + !----------------------------------------------------------------------- + + ! + ! 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 + logical, optional, intent(in) :: flag_xyfill + character(len=*), optional, intent(in) :: mixing_ratio + + ! + ! Local workspace + ! + character(len=max_chars), allocatable :: dimnames(:) + integer :: index + integer :: ierr + character(len=*), parameter :: subname = 'history_add_field_1d' + + if (trim(vdim_name) == trim(horiz_only)) then + allocate(dimnames(0), stat=ierr) + call check_allocate(ierr, subname, 'dimnames', & + file=__FILE__, line=__LINE__-1) + 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), stat=ierr) + call check_allocate(ierr, subname, 'dimnames', & + file=__FILE__, line=__LINE__-1) + dimnames(1) = trim(vdim_name) + end if + 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, 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 + 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 + use string_utils, only: stringify + + 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 + 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 :: num_levels + integer, allocatable :: mdim_indices(:) + integer, allocatable :: mdim_sizes(:) + integer, allocatable :: field_shape(:) + 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_loc + character(len=*), parameter :: subname = 'history_add_field_nd: ' + + 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 + ! + ! 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 + 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 + end if + write(errmsg, *) 'Field name, "', trim(diagnostic_name), '" is too long ', '(len=', & + stringify((/len_trim(fname_tmp)/)), ' longer than max length of ', & + stringify((/fieldname_len/)), ')' + 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 (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)) + 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)), stat=ierr) + call check_allocate(ierr, subname, 'mdim_indices', file=__FILE__, line=__LINE__-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), 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) + 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_loc, & + 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_loc, & + 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) + !----------------------------------------------------------------------- + ! + ! 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 + 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 + real(r8), intent(in) :: field_values(:) + + ! Local variables + integer :: file_idx + character(len=cl) :: errmsg + type(hist_log_messages) :: logger + character(len=*), parameter :: subname = 'history_out_field_1d: ' + class(hist_field_info_t), pointer :: field_info + + errmsg = '' + + do file_idx = 1, size(hist_configs) + ! 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! + call hist_field_accumulate(field_info, field_values, 1, logger=logger) + if (masterproc) then + call logger%output(iulog) + end if + + end do + + end subroutine history_out_field_1d + +!=========================================================================== + + subroutine history_out_field_2d(diagnostic_name, field_values) + !----------------------------------------------------------------------- + ! + ! 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 + 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 + real(r8), intent(in) :: field_values(:,:) + + ! Local variables + integer :: file_idx + character(len=cl) :: errmsg + type(hist_log_messages) :: logger + character(len=*), parameter :: subname = 'history_out_field_2d: ' + class(hist_field_info_t), pointer :: field_info + + errmsg = '' + + do file_idx = 1, size(hist_configs) + ! 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! + call hist_field_accumulate(field_info, field_values, 1, logger=logger) + if (masterproc) then + call logger%output(iulog) + end if + end do + + end subroutine history_out_field_2d + +!=========================================================================== + + subroutine history_out_field_3d(diagnostic_name, field_values) + !----------------------------------------------------------------------- + ! + ! Purpose: Accumulate active fields - 3d fields + ! + !----------------------------------------------------------------------- + use hist_api, only: hist_field_accumulate + use cam_abortutils, only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + ! Dummy variables + character(len=*), intent(in) :: diagnostic_name + real(r8), intent(in) :: field_values(:,:,:) + + ! Local variables + integer :: file_idx + character(len=cl) :: errmsg + character(len=*), parameter :: subname = 'history_out_field_3d: ' + 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) + ! 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 + ! peverwhee - TODO - need to enable 3D accumulation in modular history + ! Field is active on this file - accumulate! + !call hist_field_accumulate(field_info, real(field_values, REAL64), 1) + !if (masterproc) then + ! call logger%output(iulog) + !end if + + end do + + 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 + use shr_kind_mod, only: r8 => shr_kind_r8 + ! + !----------------------------------------------------------------------- + ! + ! 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 written (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 + 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 writes a history file to disk + ! 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 .and. num_samples > 0) then + full = .true. + end if + if ((full .or. (last_timestep .and. num_samples >= 1)) .and. & + hist_configs(file_idx)%are_files_open()) 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 (trim(hist_configs(file_idx)%get_volume()) == 'h0') then + write(iulog,*)' Primary history file' + else + write(iulog,*)' Auxiliary history file ', hist_configs(file_idx)%get_volume() + end if + 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 + call hist_configs(file_idx)%clear_buffers() + 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 new file mode 100644 index 00000000..0e4eec70 --- /dev/null +++ b/src/history/cam_history_support.F90 @@ -0,0 +1,1340 @@ +module cam_history_support + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! + !! cam_history_support is used by cam_history as well as by the dycores + !! (for vertical coordinate support). + !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use shr_kind_mod, only: r8=>shr_kind_r8, shr_kind_cl, shr_kind_cxx + use cam_grid_support, only: max_hcoordname_len + + implicit none + private + save + + 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 + ! can be checked by add_hist_coord + character(len=10), parameter, public :: horiz_only = 'horiz_only' + real(r8), parameter :: error_tolerance = 1.e-12_r8 + integer, parameter :: error_msglen = 120 + integer, parameter :: error_msglen_long = 256 + + !--------------------------------------------------------------------------- + ! + ! 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 integer + 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 integer 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 + !--------------------------------------------------------------------------- + ! + ! interp_info_t: Information for lat/lon interpolated history output + ! + !--------------------------------------------------------------------------- + type, public :: 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() + 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 + public :: parse_multiplier ! Parse a repeat count and a token from input + + 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 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_int_1d + module procedure check_hist_coord_r8 + module procedure check_hist_coord_r8_1d + module procedure check_hist_coord_r8_2d + module procedure check_hist_coord_ft + module procedure check_hist_coord_all + end interface + + !!--------------------------------------------------------------------------- + + CONTAINS + + pure 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 + pure logical function check_hist_coord_char(defined, input) + + ! Input variables + character(len=*), intent(in) :: defined + character(len=*), intent(in) :: 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 + ! We have to match definitions + check_hist_coord_char = (trim(input) == trim(defined)) + end if + end function check_hist_coord_char + + pure logical function check_hist_coord_int(defined, input) + + ! Input variables + integer, intent(in) :: defined + integer, intent(in) :: 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 + ! We have to match definitions + check_hist_coord_int = (input == defined) + end if + end function check_hist_coord_int + + pure logical function check_hist_coord_int_1d(defined, input) + + ! Input variables + integer, pointer :: defined(:) + integer, pointer :: 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_int_1d = .true. + else + ! We have to match definitions + check_hist_coord_int_1d = (size(input) == size(defined)) + end if + if (check_hist_coord_int_1d .and. associated(defined)) then + ! Need to check the values + do i = 1, size(defined) + if (defined(i) /= input(i)) then + check_hist_coord_int_1d = .false. + exit + end if + end do + end if + end function check_hist_coord_int_1d + + pure logical function check_hist_coord_r8(defined, input) + + ! Input variables + real(r8), intent(in) :: defined + real(r8), intent(in) :: 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 + ! We have to match definitions (within a tolerance) + check_hist_coord_r8 = (abs(input - defined) <= error_tolerance) + end if + end function check_hist_coord_r8 + + pure logical function check_hist_coord_r8_1d(defined, input) + + ! Input variables + real(r8), pointer :: defined(:) + real(r8), pointer :: 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_r8_1d = .true. + else + ! We have to match definitions + check_hist_coord_r8_1d = (size(input) == size(defined)) + end if + if (check_hist_coord_r8_1d .and. associated(defined)) then + ! Need to check the values (within a tolerance) + do i = 1, size(defined) + if (abs(defined(i) - input(i)) > error_tolerance) then + check_hist_coord_r8_1d = .false. + exit + end if + end do + end if + end function check_hist_coord_r8_1d + + pure logical function check_hist_coord_r8_2d(defined, input) + + ! Input variables + real(r8), pointer :: defined(:,:) + real(r8), pointer :: 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_r8_2d = .true. + else + ! We have to match definitions + check_hist_coord_r8_2d = ((size(input, 1) == size(defined, 1)) .and. & + (size(input, 2) == size(defined, 2))) + end if + if (check_hist_coord_r8_2d .and. associated(defined)) then + ! Need to check the values (within a tolerance) + do j = 1, size(defined, 2) + do i = 1, size(defined, 1) + if (abs(defined(i, j) - input(i, j)) > error_tolerance) then + check_hist_coord_r8_2d = .false. + exit + end if + end do + end do + end if + end function check_hist_coord_r8_2d + + logical function check_hist_coord_ft(defined, input) + + ! Input variables + type(formula_terms_t), intent(in) :: defined + type(formula_terms_t), intent(in) :: 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 + ! 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) + 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) + use cam_abortutils, only: endrun + use string_utils, only: stringify + + ! Input variables + character(len=*), intent(in) :: name + integer, intent(in) :: vlen + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + character(len=*), intent(in) :: bounds_name + integer, pointer, intent(in) :: i_values(:) + real(r8), pointer, intent(in) :: r_values(:) + real(r8), pointer, intent(in) :: bounds(:,:) + character(len=*), intent(in) :: positive + character(len=*), intent(in) :: standard_name + type(formula_terms_t), intent(in) :: formula_terms + + ! Local variables + character(len=256) :: 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 ( ', & + stringify((/hist_coords(i)%dimsize/)), ' vs vlen= '//stringify((/vlen/))//' )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 ( "', & + trim(hist_coords(i)%long_name)//'" vs long_name= "'//trim(long_name)//'" )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 ( "', & + trim(hist_coords(i)%units)//'" vs units= "'//trim(units)//'" )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 ( "', & + trim(hist_coords(i)%bounds_name)//'" vs bounds_name= "'//trim(bounds_name)//'" )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 ( "', & + trim(hist_coords(i)%standard_name)//'" vs standard_name= "'//trim(standard_name)//'" )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 ( "', & + trim(hist_coords(i)%positive)//'" vs positive= "'//trim(positive)//'" )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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 (( ', & + stringify(hist_coords(i)%real_values),') vs r_values=( '//stringify(r_values)//' ))' + call endrun(errormsg, file=__FILE__, line=__LINE__) + else if (associated(i_values)) then + write(errormsg, *) 'ERROR: Attempt to register integer values for real dimension ',trim(name), ' ( ', & + 'i_values=(', stringify(i_values), '))' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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, (( ', & + stringify(hist_coords(i)%integer_values)//') vs i_values= ('//stringify(i_values)//') )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + else if (associated(r_values)) then + write(errormsg, *) 'ERROR: Attempt to register real values for integer dimension ', trim(name), ' ( ', & + 'r_values=(', stringify(r_values), ') )' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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, file=__FILE__, line=__LINE__) + 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, file=__FILE__, line=__LINE__) + end if + else + check_hist_coord_all = 0 + end if + end function check_hist_coord_all + + subroutine add_hist_coord_regonly(name, index) + use cam_abortutils, only: endrun + + ! Input variable + character(len=*), intent(in) :: name + integer, optional, intent(out) :: index + + ! Local variables + character(len=error_msglen) :: 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 = '' + hist_coords(registeredmdims)%dimname = '' + hist_coords(registeredmdims)%vertical_coord = .false. + 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) + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + + ! 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 + character(len=max_chars) :: local_units + character(len=max_chars) :: local_positive + character(len=max_chars) :: local_standard_name + character(len=max_chars) :: local_bounds_name + character(len=max_hcoordname_len) :: local_dimname + integer, pointer :: local_int_values(:) + real(r8), pointer :: local_real_values(:) + real(r8), pointer :: local_bounds(:,:) + type(formula_terms_t) :: local_formula_terms + + nullify(local_int_values) + nullify(local_real_values) + nullify(local_bounds) + local_bounds_name = '' + + if (present(units)) then + local_units = units + else + local_units = '' + end if + + if (present(positive)) then + local_positive = positive + else + local_positive = '' + end if + + if (present(standard_name)) then + local_standard_name = standard_name + else + local_standard_name = '' + end if + + if (present(dimname)) then + local_dimname = dimname + else + local_dimname = '' + end if + + if (present(values)) then + local_int_values => values + end if + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen, long_name, local_units, local_bounds, & + local_int_values, local_real_values, local_bounds_name, local_positive, & + local_standard_name, local_formula_terms) + + ! 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', & + ' and will be truncated on history files' + end if + end if + hist_coords(i)%long_name = trim(long_name) + hist_coords(i)%units = trim(local_units) + hist_coords(i)%integer_dim = .true. + hist_coords(i)%integer_values => local_int_values + hist_coords(i)%positive = trim(local_positive) + hist_coords(i)%standard_name = trim(local_standard_name) + hist_coords(i)%vertical_coord = .false. + hist_coords(i)%dimname = trim(local_dimname) + + 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) + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + + ! 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=error_msglen) :: errormsg + integer :: i + character(len=max_chars) :: local_positive + character(len=max_chars) :: local_standard_name + character(len=max_chars) :: local_bounds_name + character(len=max_hcoordname_len) :: local_dimname + integer, pointer :: local_int_values(:) + real(r8), pointer :: local_bounds(:,:) + type(formula_terms_t) :: local_formula_terms + + nullify(local_int_values) + nullify(local_bounds) + + if (present(positive)) then + local_positive = positive + else + local_positive = '' + end if + + if (present(standard_name)) then + local_standard_name = standard_name + else + local_standard_name = '' + end if + + if (present(dimname)) then + local_dimname = dimname + else + local_dimname = '' + end if + + if (present(bounds)) then + local_bounds => bounds + if (.not. present(bounds_name)) then + write(errormsg,*) 'bounds_name must be present for bounds values' + call endrun(errormsg) + end if + end if + + if (present(bounds_name)) then + if (.not. present(bounds)) then + write(errormsg,*) 'bounds must be present for ',trim(bounds_name) + call endrun(errormsg) + end if + local_bounds_name = bounds_name + else + local_bounds_name = '' + end if + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen, long_name, units, local_bounds, & + local_int_values, values, local_bounds_name, local_positive, & + local_standard_name, local_formula_terms) + + ! 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', & + ' and will be truncated on history files' + 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 + hist_coords(i)%positive = trim(local_positive) + hist_coords(i)%standard_name = trim(local_standard_name) + hist_coords(i)%bounds_name = trim(local_bounds_name) + hist_coords(i)%bounds => local_bounds + if (present(vertical_coord)) then + hist_coords(i)%vertical_coord = vertical_coord + end if + hist_coords(i)%dimname = trim(local_dimname) + + end subroutine add_hist_coord_r8 + + subroutine add_vert_coord(name, vlen, long_name, units, values, & + positive, standard_name, formula_terms) + use cam_logfile, only: iulog + use spmd_utils, only: masterproc + + ! 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 + character(len=max_chars) :: local_units + character(len=max_chars) :: local_positive + character(len=max_chars) :: local_standard_name + character(len=max_chars) :: local_bounds_name + character(len=max_hcoordname_len) :: local_dimname + integer, pointer :: local_int_values(:) + real(r8), pointer :: local_real_values(:) + real(r8), pointer :: local_bounds(:,:) + type(formula_terms_t) :: local_formula_terms + + nullify(local_int_values) + nullify(local_real_values) + nullify(local_bounds) + local_bounds_name = '' + local_dimname = '' + + if (present(positive)) then + local_positive = positive + else + local_positive = '' + end if + + if (present(standard_name)) then + local_standard_name = standard_name + else + local_standard_name = '' + end if + + if (present(formula_terms)) then + local_formula_terms = formula_terms + end if + + ! First, check to see if it is OK to add this coord + i = check_hist_coord(name, vlen, long_name, local_units, local_bounds, & + local_int_values, local_real_values, local_bounds_name, local_positive, & + local_standard_name, local_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)) + end if + + hist_coords(i)%formula_terms = local_formula_terms + + 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 + use cam_abortutils, only: endrun + use cam_pio_utils, only: cam_pio_handle_error + + ! 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=error_msglen_long) :: errormsg + character(len=max_chars) :: formula_terms ! Constructed string + integer :: ierr + integer :: dtype + logical :: defvar ! True if var exists + character(len=*), parameter :: subname = 'write_hist_coord_attr' + + ! 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 + if(len_trim(hist_coords(mdimind)%long_name) > 0) then + ierr=pio_put_att(File, vardesc, 'long_name', & + trim(hist_coords(mdimind)%long_name)) + write(errormsg,*) subname, ': Error writing "long_name" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (long_name="', & + trim(hist_coords(mdimind)%long_name), '")' + call cam_pio_handle_error(ierr, errormsg) + end if + ! units + if(len_trim(hist_coords(mdimind)%units) > 0) then + ierr=pio_put_att(File, vardesc, 'units', & + trim(hist_coords(mdimind)%units)) + write(errormsg,*) subname, ': Error writing "units" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (units="', & + trim(hist_coords(mdimind)%units), '")' + call cam_pio_handle_error(ierr, errormsg) + end if + ! positive + if(len_trim(hist_coords(mdimind)%positive) > 0) then + ierr=pio_put_att(File, vardesc, 'positive', & + trim(hist_coords(mdimind)%positive)) + write(errormsg,*) subname, ': Error writing "positive" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (positive="', & + trim(hist_coords(mdimind)%positive), '")' + call cam_pio_handle_error(ierr, errormsg) + 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)) + write(errormsg,*) subname, ': Error writing "standard_name" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (standard_name="', & + trim(hist_coords(mdimind)%standard_name), '")' + call cam_pio_handle_error(ierr, errormsg) + 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)) + write(errormsg,*) subname, ': Error writing "formula_terms" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms="', & + trim(formula_terms), '")' + call cam_pio_handle_error(ierr, errormsg) + 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)) + write(errormsg,*) subname, ': Error writing "bounds" attr for variable "', & + trim(hist_coords(mdimind)%name), '" (bounds_name="', & + trim(hist_coords(mdimind)%bounds_name), '")' + call cam_pio_handle_error(ierr, errormsg) + 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 + 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)) + write(errormsg,*) subname, ': Error writing "long_name" attr for "a" formula_term for variable "', & + trim(hist_coords(mdimind)%name), '" (a_long_name="', & + trim(hist_coords(mdimind)%formula_terms%a_long_name), '")' + call cam_pio_handle_error(ierr, errormsg) + 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)) + write(errormsg,*) subname, ': Error writing "long_name" attr for "b" formula_term for variable "', & + trim(hist_coords(mdimind)%name), '" (b_long_name="', & + trim(hist_coords(mdimind)%formula_terms%b_long_name), '")' + call cam_pio_handle_error(ierr, errormsg) + 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) + write(errormsg,*) subname, ': Unable to define "p0" formula_terms variable for "', & + trim(hist_coords(mdimind)%name), '" (p0_name="', & + trim(hist_coords(mdimind)%formula_terms%p0_name), '")' + call cam_pio_handle_error(ierr, errormsg) + ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%p0_long_name)) + write(errormsg,*) subname, ': Error writing "long_name" attr for "p0" formula_term for "', & + trim(hist_coords(mdimind)%name), '" (p0_long_name="', & + trim(hist_coords(mdimind)%formula_terms%p0_long_name), '")' + call cam_pio_handle_error(ierr, errormsg) + ierr = pio_put_att(File, vardesc, 'units', trim(hist_coords(mdimind)%formula_terms%p0_units)) + write(errormsg,*) subname, ': Error writing "units" attr for "p0" formula_term for "', & + trim(hist_coords(mdimind)%name), '" (p0_units="', & + trim(hist_coords(mdimind)%formula_terms%p0_units), '")' + call cam_pio_handle_error(ierr, errormsg) + 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 + use cam_pio_utils, only: cam_pio_handle_error + use cam_abortutils,only: check_allocate + + ! Input variables + type(file_desc_t), intent(inout) :: File ! PIO file Handle + integer, intent(in) :: boundsdim ! Bounds dimension ID + logical, optional, intent(in) :: writemdims_in ! Write mdim variable + integer, optional, allocatable, intent(out) :: mdimids(:) ! NetCDF dim IDs + + ! 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 + character(len=error_msglen) :: errormsg + character(len=*), parameter :: subname = 'write_hist_coord_attrs' + + if (present(mdimids)) then + allocate(mdimids(registeredmdims), stat=ierr) + call check_allocate(ierr, subname, 'mdimids', file=__FILE__, line=__LINE__-1) + 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') + write(errormsg, *) subname, ': Error writing "long_name" attr for mdimnames"' + call cam_pio_handle_error(ierr, errormsg) + 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 + use cam_pio_utils, only: cam_pio_handle_error + use string_utils, only: stringify + + ! 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 + character(len=error_msglen_long) :: errormsg + character(len=*), parameter :: subname = 'write_hist_coord_var' + + 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) + write(errormsg,*) subname, ': Error writing values for nonexistent dimension variable "', & + trim(hist_coords(mdimind)%name), '"' + call cam_pio_handle_error(ierr, errormsg) + ! 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 + write(errormsg,*) subname, ': Error writing variable values for "', & + trim(hist_coords(mdimind)%name), '"' + call cam_pio_handle_error(ierr, errormsg) + 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) + write(errormsg,*) subname, ': Error writing values for nonexistent bounds for variable "', & + trim(hist_coords(mdimind)%name), '"' + call cam_pio_handle_error(ierr, errormsg) + ! Write out the values for this bounds variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%bounds) + write(errormsg,*) subname, ': Error writing bounds values for "', & + trim(hist_coords(mdimind)%name), '"' + call cam_pio_handle_error(ierr, errormsg) + 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) + write(errormsg,*) subname, ': Error writing values for nonexistent "a" formula_terms for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%a_name="', & + trim(hist_coords(mdimind)%formula_terms%a_name), '")' + call cam_pio_handle_error(ierr, errormsg) + ! Write out the values for this "a" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%a_values) + write(errormsg,*) subname, ': Error writing "a" formula_terms values for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%a_values="', & + stringify(hist_coords(mdimind)%formula_terms%a_values), '")' + call cam_pio_handle_error(ierr, errormsg) + 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) + write(errormsg,*) subname, ': Error writing values for nonexistent "b" formula_terms for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%b_name="', & + trim(hist_coords(mdimind)%formula_terms%b_name), '")' + call cam_pio_handle_error(ierr, errormsg) + ! Write out the values for this "b" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%b_values) + write(errormsg,*) subname, ': Error writing "b" formula_terms values for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%b_values="', & + stringify(hist_coords(mdimind)%formula_terms%b_values), '")' + call cam_pio_handle_error(ierr, errormsg) + 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) + write(errormsg,*) subname, ': Error writing values for nonexistent "p0" formula_terms for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%p0_name="', & + trim(hist_coords(mdimind)%formula_terms%p0_name), '")' + call cam_pio_handle_error(ierr, errormsg) + ! Write out the values for this "p0" formula_terms variable + ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%p0_value) + write(errormsg,*) subname, ': Error writing "p0" formula_terms value for variable "', & + trim(hist_coords(mdimind)%name), '" (formula_terms%p0_value="', & + stringify((/hist_coords(mdimind)%formula_terms%p0_value/)), '")' + call cam_pio_handle_error(ierr, errormsg) + 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 + use cam_pio_utils, only: cam_pio_handle_error + use cam_abortutils,only: check_allocate + + ! 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(:) + character(len=*), parameter :: subname = 'write_hist_coord_vars' + + ! 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), stat=ierr) + call check_allocate(ierr, subname, 'mdimnames', file=__FILE__, line=__LINE__-1) + 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) + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + ! Dummy arguments + character(len=*), intent(in) :: mdimnames(:) + integer, intent(out) :: mdimindicies(:) + + ! Local variables + integer :: i, j + integer :: cnt + character(len=error_msglen) :: errormsg + + + cnt = size(mdimnames) + mdimindicies = -1 + + + do j=1,cnt + do i = 1, registeredmdims + if(mdimnames(j) == hist_coords(i)%name) then + mdimindicies(j)=i + end if + end do + end do + do j = 1, cnt + if(mdimindicies(j) < 0) then + write(iulog,*) 'history coordinate indices and names:' + do i = 1, registeredmdims + write(iulog,*) i,hist_coords(i)%name + end do + write(errormsg,*) 'Name ',mdimnames(j),' is not a registered history coordinate' + call endrun(errormsg, file=__FILE__, line=__LINE__) + 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) + use cam_abortutils, only: endrun + ! 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 registered 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 + + subroutine parse_multiplier(input, multiplier, token, allowed_set, errmsg) + use shr_string_mod, only: to_lower => shr_string_toLower + ! 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 + character(len=error_msglen) :: ioerrmsg ! Read error message + 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, iomsg=ioerrmsg) 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), "'. ", & + "Error message from read(): '", trim(ioerrmsg), "'" + 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 subroutine parse_multiplier + +end module cam_history_support diff --git a/src/physics/ncar_ccpp b/src/physics/ncar_ccpp index fbea5c86..e95c172d 160000 --- a/src/physics/ncar_ccpp +++ b/src/physics/ncar_ccpp @@ -1 +1 @@ -Subproject commit fbea5c86954f6d043d8d8a94715cb745469114b8 +Subproject commit e95c172d7a5a0ebf054f420b08416228e211baa3 diff --git a/src/utils/cam_abortutils.F90 b/src/utils/cam_abortutils.F90 index b2ac2fc2..ca6cd2ce 100644 --- a/src/utils/cam_abortutils.F90 +++ b/src/utils/cam_abortutils.F90 @@ -66,6 +66,7 @@ subroutine cam_register_open_file(file, file_name) ! Local variables type(open_file_pointer), pointer :: of_ptr type(open_file_pointer), pointer :: of_new + integer :: ierr character(len=*), parameter :: subname = 'cam_register_open_file' nullify(of_new) @@ -80,6 +81,9 @@ subroutine cam_register_open_file(file, file_name) ! If we get here, go ahead and register the file if (associated(open_files_pool)) then of_new => open_files_pool + allocate(of_new%file_desc, stat=ierr) + call check_allocate(ierr, subname, 'of_file%file_desc', file=__FILE__, & + line=__LINE__) of_new%file_desc = file of_new%file_name = file_name allocate(open_files_pool%next) diff --git a/src/utils/cam_field_read.F90 b/src/utils/cam_field_read.F90 index 828d4698..af3e5080 100644 --- a/src/utils/cam_field_read.F90 +++ b/src/utils/cam_field_read.F90 @@ -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 @@ -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 + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr call safe_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 @@ -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 + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr call safe_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 @@ -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 + write(errormsg, *) subname, & + ': cam_pio_inq_var_fill failed with PIO error: ', ierr call safe_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 new file mode 100644 index 00000000..7ce96be5 --- /dev/null +++ b/src/utils/cam_filenames.F90 @@ -0,0 +1,286 @@ +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 + + implicit none + private + save + + public :: get_dir ! Get the directory name from a full path + public :: interpret_filename_spec ! Interpret a filename specifier + +!============================================================================== +CONTAINS +!============================================================================== + + pure 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, accum_type, & + prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec, incomplete_ok) + use time_manager, only: get_curr_date, get_prev_date + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use cam_control_mod, only: caseid + + ! Create a filename from a filename specifier. The + ! filename specifier 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 () + ! %f for accumulation file () + ! %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 + ! 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 + 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 + integer, optional, intent(in) :: yr_spec + 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 + 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 + logical :: incomplete_ok_use + 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 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 + ! + 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. incomplete_ok_use) then + 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 + else + if (present(yr_spec)) then + year = yr_spec + end if + if (present(mon_spec)) then + month = mon_spec + end if + if (present(day_spec)) then + day = day_spec + end if + if (present(sec_spec)) then + ncsec = sec_spec + end if + end if ! No else, do not use these quantities below. + ! + ! Go through each character in the filename specifier 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 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 function, 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 (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 function, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) + end if + case('f') ! accumulate flag (i or a) + if (present(accum_type)) then + string = trim(accum_type) + else if (incomplete_ok_use) then + string = "%f" + else + write(string, *) "flag needed in filename_spec, ", & + "but not provided to function, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) + end if + case('i') ! instance description (e.g., _0001) + 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 function, filename_spec = '", & + trim(filename_spec), "'" + if (masterproc) then + write(iulog, *) subname, trim(string) + end if + call endrun(subname//trim(string)) + end if + case('y') ! year + if (.not. present(yr_spec) .and. incomplete_ok_use) then + string = '%y' + else + 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 + case('m') ! month + if (.not. present(mon_spec) .and. incomplete_ok_use) then + string = '%m' + else + write(string,'(i2.2)') month + end if + case('d') ! day + if (.not. present(day_spec) .and. incomplete_ok_use) then + string = '%d' + else + write(string,'(i2.2)') day + end if + case('s') ! second + 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 + 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 + 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, trying to add: '"// & + trim(string)//"' to '"//trim(interpret_filename_spec)//"'") + 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. Filename spec: "//trim(filename_spec)) + end if + + end function interpret_filename_spec + +end module cam_filenames diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index 82d19671..1e4fc966 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -2,6 +2,7 @@ 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_kind_mod, only: shr_kind_cm use shr_sys_mod, only: shr_sys_flush use cam_map_utils, only: iMap use pio, only: var_desc_t @@ -15,7 +16,14 @@ module cam_grid_support 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 @@ -33,8 +41,8 @@ module cam_grid_support 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 + 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 @@ -55,7 +63,7 @@ module cam_grid_support 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() + 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 @@ -103,7 +111,7 @@ module cam_grid_support 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 + 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 @@ -120,7 +128,7 @@ module cam_grid_support 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 + 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 @@ -157,7 +165,7 @@ module cam_grid_support 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 :: attrs_defined(max_split_files) = .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() @@ -185,8 +193,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 @@ -206,11 +216,11 @@ module cam_grid_support 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 + 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 @@ -265,12 +275,13 @@ module cam_grid_support ! Abstract interface for write_attr procedure of cam_grid_attribute_t class abstract interface - subroutine write_cam_grid_attr(attr, File) + 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 @@ -343,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 cam_grid_write_dist_array @@ -463,6 +476,7 @@ end subroutine horiz_coord_units function horiz_coord_create(name, dimname, dimsize, long_name, units, & lbound, ubound, values, map, bnds) result(newcoord) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: name @@ -477,8 +491,12 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, & integer(iMap), intent(in), optional :: map(ubound-lbound+1) real(r8), intent(in), optional :: bnds(2,lbound:ubound) type(horiz_coord_t), pointer :: newcoord + ! Local variables + integer :: ierr + character(len=*), parameter :: subname = 'horiz_coord_create' - allocate(newcoord) + allocate(newcoord, stat=ierr) + call check_allocate(ierr, subname, 'newcoord', file=__FILE__, line=__LINE__-1) newcoord%name = trim(name) newcoord%dimname = trim(dimname) @@ -505,7 +523,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, & else call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'") end if - allocate(newcoord%values(lbound:ubound)) + allocate(newcoord%values(lbound:ubound), stat=ierr) + call check_allocate(ierr, subname, 'newcoord%values', file=__FILE__, line=__LINE__-1) if (ubound >= lbound) then newcoord%values(:) = values(:) end if @@ -514,7 +533,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, & if (ANY(map < 0)) then call endrun("horiz_coord_create "//trim(name)//": map vals < 0") end if - allocate(newcoord%map(ubound - lbound + 1)) + allocate(newcoord%map(ubound - lbound + 1), stat=ierr) + call check_allocate(ierr, subname, 'newcoord%map', file=__FILE__, line=__LINE__-1) if (ubound >= lbound) then newcoord%map(:) = map(:) end if @@ -523,7 +543,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, & end if if (present(bnds)) then - allocate(newcoord%bnds(2, lbound:ubound)) + allocate(newcoord%bnds(2, lbound:ubound), stat=ierr) + call check_allocate(ierr, subname, 'newcoord%bnds', file=__FILE__, line=__LINE__-1) if (ubound >= lbound) then newcoord%bnds = bnds end if @@ -542,15 +563,17 @@ end function horiz_coord_create ! !------------------------------------------------------------------------ - subroutine write_horiz_coord_attr(this, File, dimid_out) + 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 + use cam_abortutils, only: check_allocate ! 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 @@ -559,10 +582,18 @@ subroutine write_horiz_coord_attr(this, File, dimid_out) integer :: bnds_dimid ! PIO dim for bounds integer :: err_handling integer :: ierr + integer :: file_index_loc + character(len=*), parameter :: subname = 'write_horiz_coord_attr' ! 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, & @@ -571,53 +602,61 @@ subroutine write_horiz_coord_attr(this, File, dimid_out) 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 + 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)) + call endrun(subname//' vardesc already allocated for '//trim(dimname)) end if - allocate(this%vardesc) + allocate(this%vardesc(file_index_loc)%p, stat=ierr) + call check_allocate(ierr, subname, 'this%vardesc(file_index_loc)%p', & + file=__FILE__, line=__LINE__-1) 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) + (/ 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') + 'Error writing "_FillValue" attr in '//subname) ! long_name - ierr=pio_put_att(File, this%vardesc, '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') + 'Error writing "long_name" attr in '//subname) ! units - ierr=pio_put_att(File, this%vardesc, 'units', trim(this%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') + 'Error writing "units" attr in '//subname) ! Take care of bounds if they exist if (associated(this%bnds)) then - allocate(this%bndsvdesc) - ierr = pio_put_att(File, this%vardesc, 'bounds', & + allocate(this%bndsvdesc(file_index_loc)%p, stat=ierr) + call check_allocate(ierr, subname, & + 'this%bndsvdesc(file_index_loc)%p', file=__FILE__, & + line=__LINE__-1) + 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') + 'Error writing "'//trim(this%name)//'_bnds" attr in '//subname) 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.) + (/ 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') + 'Error defining "'//trim(this%name)//'_bnds" in '//subname) ! long_name - ierr = pio_put_att(File, this%bndsvdesc, 'long_name', & - trim(this%name)//' bounds') + 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') + 'Error writing bounds "long_name" attr in '//subname) ! fill value - ierr = pio_put_att(File, this%vardesc, '_FillValue', & - grid_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') + 'Error writing "_FillValue" attr in '//subname) ! units - ierr = pio_put_att(File, this%bndsvdesc, 'units', & - trim(this%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') + 'Error writing bounds "units" attr in '//subname) end if ! There are bounds for this coordinate end if ! We define the variable @@ -638,7 +677,7 @@ end subroutine write_horiz_coord_attr ! !------------------------------------------------------------------------ - subroutine write_horiz_coord_var(this, File) + 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 @@ -651,18 +690,25 @@ subroutine write_horiz_coord_var(this, File) ! 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 + character(len=shr_kind_cm) :: errormsg integer :: ierr integer :: ldims(1) integer :: fdims(1) integer :: err_handling - type(io_desc_t), pointer :: iodesc + type(io_desc_t) :: iodesc + integer :: file_index_loc + + if (present(file_index)) then + file_index_loc = file_index + else + file_index_loc = 1 + end if - nullify(iodesc) ! Check to make sure we are supposed to write this var - if (associated(this%vardesc)) then + 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) @@ -675,21 +721,24 @@ subroutine write_horiz_coord_var(this, File) 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) + 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, iodesc, this%values, ierr) + 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)) then + 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, iodesc, & - this%bnds, ierr) + 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 @@ -697,10 +746,13 @@ subroutine write_horiz_coord_var(this, File) !!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) + 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)) then - ierr = pio_put_var(File, this%bndsvdesc, this%bnds) + 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 ', & @@ -711,12 +763,12 @@ subroutine write_horiz_coord_var(this, File) call pio_seterrorhandling(File, err_handling) ! We are done with this variable descriptor, reset for next file - deallocate(this%vardesc) - nullify(this%vardesc) + deallocate(this%vardesc(file_index_loc)%p) + nullify(this%vardesc(file_index_loc)%p) ! Same with the bounds descriptor - if (associated(this%bndsvdesc)) then - deallocate(this%bndsvdesc) - nullify(this%bndsvdesc) + 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? @@ -823,6 +875,7 @@ 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) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: name integer, intent(in) :: id @@ -837,9 +890,10 @@ subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & ! Local variables character(len=max_hcoordname_len) :: latdimname, londimname - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: i integer :: src(2), dest(2) + integer :: ierr character(len=*), parameter :: subname = 'CAM_GRID_REGISTER' ! For a values grid, we do not allow multiple calls @@ -912,7 +966,9 @@ subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, & dest(2) = 2 end if end if - allocate(cam_grids(registeredhgrids)%map) + allocate(cam_grids(registeredhgrids)%map, stat=ierr) + call check_allocate(ierr, subname, 'cam_grids(registeredhgrids)%map',& + file=__FILE__, line=__LINE__-1) call cam_grids(registeredhgrids)%map%init(map, & cam_grids(registeredhgrids)%unstructured, src, dest) call cam_grids(registeredhgrids)%print_cam_grid() @@ -986,7 +1042,7 @@ integer function cam_grid_get_local_size(id, nlev) ! Local variables integer :: gridid - character(len=128) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1013,7 +1069,7 @@ subroutine cam_grid_get_file_dimids(id, File, dimids) ! Local variables integer :: gridid - character(len=128) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1043,7 +1099,7 @@ subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, & ! Local variables integer :: gridid - character(len=128) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1077,7 +1133,7 @@ subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1112,7 +1168,7 @@ subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1147,7 +1203,7 @@ subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1182,7 +1238,7 @@ subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1217,7 +1273,7 @@ subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1252,7 +1308,7 @@ subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1287,7 +1343,7 @@ subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1322,7 +1378,7 @@ subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1336,6 +1392,41 @@ subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, & 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=shr_kind_cm) :: 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 @@ -1357,7 +1448,7 @@ subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1392,7 +1483,7 @@ subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1406,6 +1497,41 @@ subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, & 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=shr_kind_cm) :: 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 @@ -1427,7 +1553,7 @@ subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1462,7 +1588,7 @@ subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, & ! Local variable integer :: gridid - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridid = get_cam_grid_index(id) if (gridid > 0) then @@ -1593,7 +1719,7 @@ subroutine cam_grid_get_dim_names_name(gridname, name1, name2) ! Local variables integer :: gridind - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridind = get_cam_grid_index(trim(gridname)) if (gridind < 0) then @@ -1858,6 +1984,7 @@ end subroutine print_attr_0d_char subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & dimsize, values, map) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_attribute_1d_int_t) :: this character(len=*), intent(in) :: name @@ -1866,6 +1993,9 @@ subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & integer, intent(in) :: dimsize integer, target, intent(in) :: values(:) integer(iMap), optional, target, intent(in) :: map(:) + ! Local variables + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_attr_init_1d_int' ! call this%cam_grid_attr_init(trim(name), trim(long_name)) if (len_trim(name) > max_hcoordname_len) then @@ -1885,7 +2015,8 @@ subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, & this%values => values ! Fill in the optional map if (present(map)) then - allocate(this%map(size(map))) + allocate(this%map(size(map)), stat=ierr) + call check_allocate(ierr, subname, 'this%map', file=__FILE__, line=__LINE__-1) this%map(:) = map(:) else nullify(this%map) @@ -1894,6 +2025,7 @@ end subroutine cam_grid_attr_init_1d_int subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & dimsize, values, map) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_attribute_1d_r8_t) :: this character(len=*), intent(in) :: name @@ -1902,6 +2034,9 @@ subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & integer, intent(in) :: dimsize real(r8), target, intent(in) :: values(:) integer(iMap), optional, target, intent(in) :: map(:) + ! Local variables + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_attr_init_1d_r8' ! call this%cam_grid_attr_init(trim(name), trim(long_name), next) this%name = trim(name) @@ -1912,7 +2047,8 @@ subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, & this%values => values ! Fill in the optional map if (present(map)) then - allocate(this%map(size(map))) + allocate(this%map(size(map)), stat=ierr) + call check_allocate(ierr, subname, 'this%map', file=__FILE__, line=__LINE__-1) this%map(:) = map(:) else nullify(this%map) @@ -1938,13 +2074,17 @@ subroutine print_attr_1d_r8(this) end subroutine print_attr_1d_r8 subroutine insert_grid_attribute(gridind, attr) + use cam_abortutils, only: check_allocate 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 + integer :: ierr + character(len=*), parameter :: subname = 'insert_grid_attribute' - allocate(attrPtr) + allocate(attrPtr, stat=ierr) + call check_allocate(ierr, subname, 'attrPtr', file=__FILE__, line=__LINE__-1) call attrPtr%initialize(attr) call attrPtr%setNext(cam_grids(gridind)%attributes) cam_grids(gridind)%attributes => attrPtr @@ -1952,6 +2092,7 @@ subroutine insert_grid_attribute(gridind, attr) end subroutine insert_grid_attribute subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: gridname character(len=*), intent(in) :: name @@ -1961,8 +2102,10 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) ! Local variables type(cam_grid_attribute_0d_int_t), pointer :: attr class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: gridind + integer :: ierr + character(len=*), parameter :: subname = 'add_cam_grid_attribute_0d_int' gridind = get_cam_grid_index(trim(gridname)) if (gridind > 0) then @@ -1975,7 +2118,9 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) call endrun(errormsg) else ! Need a new attribute. - allocate(attr) + allocate(attr, stat=ierr) + call check_allocate(ierr, subname, 'attr', file=__FILE__, & + line=__LINE__-1) call attr%cam_grid_attr_init_0d_int(trim(name), & trim(long_name), val) attptr => attr @@ -1990,6 +2135,7 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val) end subroutine add_cam_grid_attribute_0d_int subroutine add_cam_grid_attribute_0d_char(gridname, name, val) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: gridname character(len=*), intent(in) :: name @@ -1998,8 +2144,10 @@ subroutine add_cam_grid_attribute_0d_char(gridname, name, val) ! Local variables type(cam_grid_attribute_0d_char_t), pointer :: attr class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: gridind + integer :: ierr + character(len=*), parameter :: subname = 'add_cam_grid_attribute_0d_char' gridind = get_cam_grid_index(trim(gridname)) if (gridind > 0) then @@ -2012,7 +2160,9 @@ subroutine add_cam_grid_attribute_0d_char(gridname, name, val) call endrun(errormsg) else ! Need a new attribute. - allocate(attr) + allocate(attr, stat=ierr) + call check_allocate(ierr, subname, 'attr', file=__FILE__, & + line=__LINE__-1) call attr%cam_grid_attr_init_0d_char(trim(name), '', val) attptr => attr call insert_grid_attribute(gridind, attptr) @@ -2027,6 +2177,7 @@ end subroutine add_cam_grid_attribute_0d_char subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & dimname, values, map) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: gridname character(len=*), intent(in) :: name @@ -2038,9 +2189,11 @@ subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & ! Local variables type(cam_grid_attribute_1d_int_t), pointer :: attr class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: gridind integer :: dimsize + integer :: ierr + character(len=*), parameter :: subname = 'add_cam_grid_attribute_1d_int' nullify(attr) nullify(attptr) @@ -2066,7 +2219,9 @@ subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, & ', not found' call endrun(errormsg) end if - allocate(attr) + allocate(attr, stat=ierr) + call check_allocate(ierr, subname, 'attr', file=__FILE__, & + line=__LINE__-1) call attr%cam_grid_attr_init_1d_int(trim(name), & trim(long_name), trim(dimname), dimsize, values, map) attptr => attr @@ -2082,6 +2237,7 @@ end subroutine add_cam_grid_attribute_1d_int subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & dimname, values, map) + use cam_abortutils, only: check_allocate ! Dummy arguments character(len=*), intent(in) :: gridname character(len=*), intent(in) :: name @@ -2093,9 +2249,11 @@ subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & ! Local variables type(cam_grid_attribute_1d_r8_t), pointer :: attr class(cam_grid_attribute_t), pointer :: attptr - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: gridind integer :: dimsize + integer :: ierr + character(len=*), parameter :: subname = 'add_cam_grid_attribute_1d_r8' gridind = get_cam_grid_index(trim(gridname)) if (gridind > 0) then @@ -2119,7 +2277,9 @@ subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, & ', not found' call endrun(errormsg) end if - allocate(attr) + allocate(attr, stat=ierr) + call check_allocate(ierr, subname, 'attr', file=__FILE__, & + line=__LINE__-1) call attr%cam_grid_attr_init_1d_r8(trim(name), & trim(long_name), trim(dimname), dimsize, values, map) attptr => attr @@ -2190,37 +2350,48 @@ end subroutine setAttrPtrNext ! !------------------------------------------------------------------------ - subroutine write_cam_grid_attr_0d_int(attr, File) + 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 + use cam_abortutils,only: check_allocate ! 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)) then + 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) + allocate(attr%vardesc(file_index_loc)%p, stat=ierr) + call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', & + file=__FILE__, line=__LINE__-1) 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)) + 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, 'long_name', & - trim(attr%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) else @@ -2248,23 +2419,31 @@ end subroutine write_cam_grid_attr_0d_int ! !------------------------------------------------------------------------ - subroutine write_cam_grid_attr_0d_char(attr, File) + 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 + 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)) then + 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) @@ -2286,24 +2465,33 @@ end subroutine write_cam_grid_attr_0d_char ! !------------------------------------------------------------------------ - subroutine write_cam_grid_attr_1d_int(attr, File) + 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 + use cam_abortutils,only: check_allocate ! 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 + character(len=shr_kind_cm) :: 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)) then + 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 @@ -2314,15 +2502,17 @@ subroutine write_cam_grid_attr_1d_int(attr, File) call endrun(errormsg) end if ! Time to define the variable - allocate(attr%vardesc) + allocate(attr%vardesc(file_index_loc)%p, stat=ierr) + call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', & + file=__FILE__, line=__LINE__-1) 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)) + 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, 'long_name', & - trim(attr%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 @@ -2337,24 +2527,33 @@ end subroutine write_cam_grid_attr_1d_int ! !------------------------------------------------------------------------ - subroutine write_cam_grid_attr_1d_r8(attr, File) + 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 pio, only: pio_double, pio_inq_dimid use cam_pio_utils, only: cam_pio_def_var + use cam_abortutils,only: check_allocate ! 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 + character(len=shr_kind_cm) :: 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)) then + 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 @@ -2365,17 +2564,19 @@ subroutine write_cam_grid_attr_1d_r8(attr, File) call endrun(errormsg) end if ! Time to define the variable - allocate(attr%vardesc) + allocate(attr%vardesc(file_index_loc)%p, stat=ierr) + call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', & + file=__FILE__, line=__LINE__-1) call cam_pio_def_var(File, trim(attr%name), pio_double, & - (/dimid/), attr%vardesc, existOK=.false.) + (/dimid/), attr%vardesc(file_index_loc)%p, existOK=.false.) ! fill value - ierr = pio_put_att(File, attr%vardesc, '_FillValue', & - grid_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, 'long_name', & - trim(attr%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 @@ -2396,7 +2597,7 @@ subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name) character(len=*), intent(in) :: attribute_name ! Local variables - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: src_ind, dest_ind class(cam_grid_attribute_t), pointer :: attr @@ -2433,14 +2634,16 @@ end subroutine cam_grid_attribute_copy ! history coordinates. ! !------------------------------------------------------------------------ - subroutine cam_grid_write_attr(File, grid_id, header_info) + 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 + use cam_abortutils, only: check_allocate ! Dummy arguments - type(file_desc_t), intent(inout) :: File ! PIO file Handle + 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 @@ -2448,13 +2651,21 @@ subroutine cam_grid_write_attr(File, grid_id, header_info) type(cam_grid_attr_ptr_t), pointer :: attrPtr integer :: dimids(2) integer :: err_handling + integer :: file_index_loc + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_write_attr' + + 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 - ! This shouldn't happen but, no harm, no foul deallocate(header_info%hdims) end if @@ -2468,26 +2679,36 @@ subroutine cam_grid_write_attr(File, grid_id, header_info) end if ! Only write this grid if not already defined - if (cam_grids(gridind)%attrs_defined) then + 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)) + allocate(header_info%hdims(1), stat=ierr) + call check_allocate(ierr, subname, 'header_info%hdims', & + file=__FILE__, line=__LINE__-1) header_info%hdims(1) = dimids(1) else - allocate(header_info%hdims(2)) + allocate(header_info%hdims(2), stat=ierr) + call check_allocate(ierr, subname, 'header_info%hdims', & + file=__FILE__, line=__LINE__-1) 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)) + 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)) + allocate(header_info%hdims(1), stat=ierr) + call check_allocate(ierr, subname, 'header_info%hdims', & + file=__FILE__, line=__LINE__-1) else allocate(header_info%hdims(2)) + call check_allocate(ierr, subname, 'header_info%hdims', & + file=__FILE__, line=__LINE__-1) header_info%hdims(2) = dimids(2) end if header_info%hdims(1) = dimids(1) @@ -2501,7 +2722,7 @@ subroutine cam_grid_write_attr(File, grid_id, header_info) !!XXgoldyXX: Is this not working in PGI? ! attr => attrPtr%getAttr() attr => attrPtr%attr - call attr%write_attr(File) + call attr%write_attr(File, file_index=file_index_loc) !!XXgoldyXX: Is this not working in PGI? ! attrPtr => attrPtr%getNext() attrPtr => attrPtr%next @@ -2509,46 +2730,54 @@ subroutine cam_grid_write_attr(File, grid_id, header_info) ! Back to previous I/O error handling call pio_seterrorhandling(File, err_handling) - - cam_grids(gridind)%attrs_defined = .true. + 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) + 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_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 character(len=*), parameter :: subname = 'write_cam_grid_val_0d_int' + 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)) then - ierr = pio_put_var(File, attr%vardesc, attr%ival) + 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) - nullify(attr%vardesc) + 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) + 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) + 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 @@ -2557,40 +2786,45 @@ subroutine write_cam_grid_val_1d_int(attr, File) ! 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 + type(io_desc_t) :: iodesc + integer :: file_index_loc character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' - nullify(iodesc) + 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 not associated, another grid write the values - if (associated(attr%vardesc)) then + 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, iodesc, attr%values, & - ierr) + 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, attr%values) + 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) - nullify(attr%vardesc) + 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) + 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 @@ -2599,58 +2833,70 @@ subroutine write_cam_grid_val_1d_r8(attr, File) ! 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 :: ierr + type(io_desc_t) :: iodesc + integer :: file_index_loc character(len=*), parameter :: subname = 'write_cam_grid_val_1d_int' - nullify(iodesc) + 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 not associated, another grid write the values - if (associated(attr%vardesc)) then + 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, iodesc, attr%values, & - ierr) + 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, attr%values) + 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) - nullify(attr%vardesc) + 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) + 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) then + if (cam_grids(gridind)%attrs_defined(file_index_loc)) then ! Write the horizontal coorinate values - call cam_grids(gridind)%lon_coord%write_var(File) - call cam_grids(gridind)%lat_coord%write_var(File) + 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, & @@ -2662,7 +2908,7 @@ subroutine cam_grid_write_var(File, grid_id) !!XXgoldyXX: Is this not working in PGI? ! attr => attrPtr%getAttr() attr => attrPtr%attr - call attr%write_val(File) + call attr%write_val(File, file_index=file_index_loc) !!XXgoldyXX: Is this not working in PGI? ! attrPtr => attrPtr%getNext() attrPtr => attrPtr%next @@ -2671,7 +2917,7 @@ subroutine cam_grid_write_var(File, grid_id) ! Back to previous I/O error handling call pio_seterrorhandling(File, err_handling) - cam_grids(gridind)%attrs_defined = .false. + cam_grids(gridind)%attrs_defined(file_index_loc) = .false. end if end subroutine cam_grid_write_var @@ -2766,7 +3012,7 @@ subroutine cam_grid_dimensions_id(gridid, dims, rank) ! Local variables integer :: index character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg index = get_cam_grid_index(gridid) if (index < 0) then @@ -2802,7 +3048,7 @@ subroutine cam_grid_dimensions_name(gridname, dims, rank) ! Local variables integer :: gridind character(len=max_hcoordname_len) :: dname1, dname2 - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg gridind = get_cam_grid_index(trim(gridname)) if (gridind < 0) then @@ -2831,6 +3077,7 @@ end subroutine cam_grid_dimensions_name subroutine cam_grid_set_map(this, map, src, dest) use spmd_utils, only: mpicom use mpi, only: mpi_sum, mpi_integer + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_t) :: this integer(iMap), pointer :: map(:,:) @@ -2841,6 +3088,7 @@ subroutine cam_grid_set_map(this, map, src, dest) integer :: dims(2) integer :: dstrt, dend integer :: gridlen, gridloc, ierr + character(len=*), parameter :: subname = 'cam_grid_set_map' ! Check to make sure the map meets our needs call this%coord_lengths(dims) @@ -2868,7 +3116,9 @@ subroutine cam_grid_set_map(this, map, src, dest) call endrun('cam_grid_set_map: Bad map size for '//trim(this%name)) else if (.not. associated(this%map)) then - allocate(this%map) + allocate(this%map, stat=ierr) + call check_allocate(ierr, subname, 'this%map', & + file=__FILE__, line=__LINE__-1) end if call this%map%init(map, this%unstructured, src, dest) end if @@ -2885,7 +3135,7 @@ integer function cam_grid_local_size(this) class(cam_grid_t) :: this ! Local variable - character(len=128) :: errormsg + character(len=shr_kind_cm) :: errormsg if (.not. associated(this%map)) then write(errormsg, *) 'Grid, '//trim(this%name)//', has no map' @@ -2946,6 +3196,7 @@ end subroutine cam_grid_get_lon_lat ! !------------------------------------------------------------------------ subroutine cam_grid_find_src_dims(this, field_dnames, src_out) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_t) :: this character(len=*), intent(in) :: field_dnames(:) @@ -2955,6 +3206,8 @@ subroutine cam_grid_find_src_dims(this, field_dnames, src_out) integer :: i, j integer :: num_coords character(len=max_hcoordname_len) :: coord_dimnames(2) + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_find_src_dims' call this%dim_names(coord_dimnames(1), coord_dimnames(2)) if (associated(src_out)) then @@ -2966,7 +3219,9 @@ subroutine cam_grid_find_src_dims(this, field_dnames, src_out) else num_coords = 2 end if - allocate(src_out(2)) ! Currently, all cases have two source dims + allocate(src_out(2), stat=ierr) ! Currently, all cases have two source dims + call check_allocate(ierr, subname, 'src_out', file=__FILE__, line=__LINE__-1) + do i = 1, num_coords do j = 1, size(field_dnames) if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then @@ -2986,6 +3241,7 @@ end subroutine cam_grid_find_src_dims ! !------------------------------------------------------------------------ subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_t) :: this character(len=*), intent(in) :: file_dnames(:) @@ -2995,6 +3251,8 @@ subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) integer :: i, j integer :: num_coords character(len=max_hcoordname_len) :: coord_dimnames(2) + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_find_dest_dims' call this%dim_names(coord_dimnames(1), coord_dimnames(2)) if (associated(dest_out)) then @@ -3006,7 +3264,8 @@ subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out) else num_coords = 2 end if - allocate(dest_out(num_coords)) + allocate(dest_out(num_coords), stat=ierr) + call check_allocate(ierr, subname, 'dest_out', file=__FILE__, line=__LINE__-1) dest_out = 0 do i = 1, num_coords do j = 1, size(file_dnames) @@ -3027,6 +3286,7 @@ 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 + use cam_abortutils,only: check_allocate ! Dummy arguments class(cam_grid_t) :: this @@ -3042,7 +3302,9 @@ subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & integer, pointer :: dest_in(:) integer, allocatable :: permutation(:) logical :: is_perm - character(len=128) :: errormsg + character(len=shr_kind_cm) :: errormsg + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_get_pio_decomp' nullify(src_in) nullify(dest_in) @@ -3061,6 +3323,8 @@ subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, & ! This only works if the arrays are the same size if (size(file_dnames) == size(field_dnames)) then allocate(permutation(size(file_dnames))) + call check_allocate(ierr, subname, 'permutation', & + file=__FILE__, line=__LINE__-1) call calc_permutation(file_dnames, field_dnames, & permutation, is_perm) end if @@ -3244,7 +3508,7 @@ end subroutine cam_grid_read_darray_2d_double ! !------------------------------------------------------------------------ subroutine cam_grid_read_darray_3d_double(this, File, adims, fdims, & - hbuf, varid) + 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 @@ -3386,10 +3650,10 @@ end subroutine cam_grid_write_darray_3d_int !------------------------------------------------------------------------ ! - ! cam_grid_write_darray_2d_double: Write a variable defined on this grid + ! cam_grid_write_darray_1d_double: Write a variable defined on this grid ! !------------------------------------------------------------------------ - subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, & + 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 @@ -3400,6 +3664,34 @@ subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, & 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 @@ -3412,10 +3704,8 @@ subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, & 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, & @@ -3443,6 +3733,35 @@ subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, & 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 @@ -3512,6 +3831,7 @@ 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 + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_t) :: this @@ -3579,23 +3899,35 @@ subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco) if (cco) then ! For collected column output, we need to collect ! coordinates and values - allocate(patch%latmap(patch%mask%num_elem())) + allocate(patch%latmap(patch%mask%num_elem()), stat=ierr) + call check_allocate(ierr, subname, 'patch%latmap', file=__FILE__, & + line=__LINE__-1) patch%latmap = 0 - allocate(patch%latvals(patch%mask%num_elem())) + allocate(patch%latvals(patch%mask%num_elem()), stat=ierr) + call check_allocate(ierr, subname, 'patch%latvals', file=__FILE__, & + line=__LINE__-1) patch%latvals = 91.0_r8 - allocate(patch%lonmap(patch%mask%num_elem())) + allocate(patch%lonmap(patch%mask%num_elem()), stat=ierr) + call check_allocate(ierr, subname, 'patch%lonmap', file=__FILE__, & + line=__LINE__-1) patch%lonmap = 0 - allocate(patch%lonvals(patch%mask%num_elem())) + allocate(patch%lonvals(patch%mask%num_elem()), stat=ierr) + call check_allocate(ierr, subname, 'patch%lonvals', file=__FILE__, & + line=__LINE__-1) 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))) + allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1)), stat=ierr) + call check_allocate(ierr, subname, 'patch%latmap', file=__FILE__, & + line=__LINE__-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))) + allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1)), stat=ierr) + call check_allocate(ierr, subname, 'patch%lonmap', file=__FILE__, & + line=__LINE__-1) patch%lonmap = 0 else nullify(patch%lonmap) @@ -3902,7 +4234,7 @@ subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, & ! Local variable integer :: index - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg character(len=max_hcoordname_len) :: grid_name logical :: unstruct @@ -3939,7 +4271,7 @@ subroutine cam_grid_patch_get_coord_long_name(this, axis, name) character(len=*), intent(out) :: name ! Local variable - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: index if (cam_grid_check(this%grid_id)) then @@ -3967,7 +4299,7 @@ subroutine cam_grid_patch_get_coord_units(this, axis, units) character(len=*), intent(out) :: units ! Local variable - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg integer :: index if (cam_grid_check(this%grid_id)) then @@ -3989,6 +4321,7 @@ end subroutine cam_grid_patch_get_coord_units subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, & id, map) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_patch_t) :: this @@ -3998,6 +4331,10 @@ subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, & integer, intent(in) :: id type(cam_filemap_t), intent(in) :: map + ! Local variables + integer :: ierr + character(len=*), parameter :: subname = 'cam_grid_patch_set_patch' + this%grid_id = id this%lon_range(1) = lonl this%lon_range(2) = lonu @@ -4005,7 +4342,9 @@ subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, & this%lat_range(2) = latu this%collected_columns = cco if (.not. associated(this%mask)) then - allocate(this%mask) + allocate(this%mask, stat=ierr) + call check_allocate(ierr, subname, 'this%mask', file=__FILE__, & + line=__LINE__-1) end if call this%mask%copy(map) call this%mask%new_index() @@ -4080,6 +4419,7 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) 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 + use cam_abortutils,only: check_allocate ! Dummy arguments class(cam_grid_patch_t) :: this @@ -4087,7 +4427,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(:) @@ -4101,7 +4441,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 @@ -4111,7 +4450,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) map => this%lonmap else field_lens(1) = 0 - allocate(map(0)) + allocate(map(0), stat=ierr) + call check_allocate(ierr, subname, 'map', file=__FILE__, & + line=__LINE__-1) end if file_lens(1) = this%global_lon_size !! XXgoldyXX: Think about caching these decomps @@ -4123,7 +4464,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) if (associated(coord_p)) then coord => coord_p else - allocate(coord(0)) + allocate(coord(0), stat=ierr) + call check_allocate(ierr, subname, 'coord', file=__FILE__, & + line=__LINE__-1) end if end if vdesc => header_info%get_lon_varid() @@ -4143,7 +4486,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) map => this%latmap else field_lens(1) = 0 - allocate(map(0)) + allocate(map(0), stat=ierr) + call check_allocate(ierr, subname, 'map', file=__FILE__, & + line=__LINE__-1) end if file_lens(1) = this%global_lat_size !! XXgoldyXX: Think about caching these decomps @@ -4156,7 +4501,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) if (associated(coord_p)) then coord => coord_p else - allocate(coord(0)) + allocate(coord(0), stat=ierr) + call check_allocate(ierr, subname, 'coord', file=__FILE__, & + line=__LINE__-1) end if end if vdesc => header_info%get_lat_varid() @@ -4221,6 +4568,7 @@ subroutine cam_grid_header_info_set_gridid(this, id) end subroutine cam_grid_header_info_set_gridid subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) + use cam_abortutils, only: check_allocate ! Dummy arguments class(cam_grid_header_info_t) :: this integer, intent(in) :: hdim1 @@ -4228,6 +4576,7 @@ subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) ! Local variables integer :: hdsize + integer :: ierr character(len=*), parameter :: subname = 'cam_grid_header_info_set_hdims' if (present(hdim2)) then @@ -4242,7 +4591,9 @@ subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2) call endrun(subname//': hdims is wrong size') end if else - allocate(this%hdims(hdsize)) + allocate(this%hdims(hdsize), stat=ierr) + call check_allocate(ierr, subname, 'this%hdims', file=__FILE__, & + line=__LINE__-1) end if this%hdims(1) = hdim1 if (present(hdim2)) then @@ -4269,7 +4620,7 @@ integer function cam_grid_header_info_hdim(this, index) result(id) integer, intent(in) :: index ! Local variable - character(len=120) :: errormsg + character(len=shr_kind_cm) :: errormsg if (allocated(this%hdims)) then if ((index >= 1) .and. (index <= size(this%hdims))) then diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90 index ad7a796a..69683cba 100644 --- a/src/utils/cam_pio_utils.F90 +++ b/src/utils/cam_pio_utils.F90 @@ -634,7 +634,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 @@ -1227,7 +1227,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_createfile, file_desc_t, pio_noerr, pio_nowrite use pio, only: pio_64bit_offset, pio_iotask_rank, pio_clobber use cam_abortutils, only : endrun, cam_register_open_file @@ -1249,8 +1249,8 @@ 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 + else if (pio_iotask_rank(pio_subsystem) == 0 .and. mode /= pio_nowrite) then + write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh call cam_register_open_file(file, trim(fname)) end if @@ -1258,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_openfile, file_desc_t, pio_nowrite use pio, only: pio_noerr, pio_iotask_rank use cam_abortutils, only: endrun, cam_register_open_file @@ -1280,7 +1280,8 @@ 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 + else if(pio_iotask_rank(pio_subsystem) == 0 .and. log_information & + .and. mode /= pio_nowrite) then write(iulog,*) 'Opened existing file ', trim(fname), file%fh call cam_register_open_file(file, trim(fname)) end if 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 21133bd1..223d54da 100644 --- a/src/utils/string_utils.F90 +++ b/src/utils/string_utils.F90 @@ -2,15 +2,17 @@ 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 ! 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 :: 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 @@ -30,9 +32,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 @@ -69,6 +68,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: '//stringify((/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. @@ -84,7 +138,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 @@ -141,7 +195,7 @@ integer function increment_string(str, increment) end function increment_string -!========================================================================================= + !=========================================================================== integer function last_index(cstr) !----------------------------------------------------------------------- @@ -180,7 +234,7 @@ integer function last_index(cstr) end function last_index -!========================================================================================= + !=========================================================================== integer function last_sig_char(cstr) !----------------------------------------------------------------------- @@ -217,21 +271,21 @@ 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 + write(to_str,'(i0)') n -end function to_str + end function to_str -!========================================================================================= + !=========================================================================== !> Convert one or more values of any intrinsic data types to a character string for pretty printing. !> If `value` contains more than one element, the elements will be stringified, delimited by `separator`, then concatenated. diff --git a/src/utils/time_manager.F90 b/src/utils/time_manager.F90 index 803a47e9..566f84b6 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 use runtime_obj, only: unset_int diff --git a/test/run_unit_tests.sh b/test/run_unit_tests.sh index 8d30fc25..a68cbf08 100755 --- a/test/run_unit_tests.sh +++ b/test/run_unit_tests.sh @@ -66,6 +66,8 @@ run_doctest cime_config/create_readnl_files.py run_doctest src/data/generate_registry_data.py # ParamGen atm_in namelist writer doctests: run_doctest cime_config/atm_in_paramgen.py +# CAM history config doctests: +run_doctest cime_config/hist_config.py # CAM config unit tests: run_unittest test/unit/test_cam_config.py # CAM autogen unit tests: @@ -80,6 +82,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/amwg_hist_config b/test/unit/sample_files/hist_config_files/amwg_hist_config new file mode 100644 index 00000000..7474c115 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/amwg_hist_config @@ -0,0 +1,16 @@ +hist_max_frames: 1 +hist_output_frequency: 1*months +hist_precision: REAL32 + +! 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..86efcd4b --- /dev/null +++ b/test/unit/sample_files/hist_config_files/atm_in_flat @@ -0,0 +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_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%f.%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%f.%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%f.%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 new file mode 100644 index 00000000..cb81dc03 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/atm_in_multi @@ -0,0 +1,72 @@ + +&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*nmonths' + hist_precision = 'REAL32' + hist_file_type = 'history' + hist_filename_spec = '%c.cam.%u%f.%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 = 'test_fname_%y.nc' + hist_write_nstep0 = .true. +/ 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..a03e0c60 --- /dev/null +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_flat @@ -0,0 +1,23 @@ +! 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 + +! 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/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..28c2ecbb --- /dev/null +++ b/test/unit/sample_files/hist_config_files/user_nl_cam_multi @@ -0,0 +1,19 @@ +! 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: 1*nmonths +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 +hist_write_nstep0;h3: .true. +hist_filename_template;h3: test_fname_%y.nc diff --git a/test/unit/sample_files/reg_good_simple.xml b/test/unit/sample_files/reg_good_simple.xml index 66451ae0..5c227b7c 100644 --- a/test/unit/sample_files/reg_good_simple.xml +++ b/test/unit/sample_files/reg_good_simple.xml @@ -20,7 +20,7 @@ horizontal_dimension lon - + The coolest constituent imaginable 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/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..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 94c4ae28..26f058cc 100644 --- a/test/unit/sample_files/write_init_files/simple_reg.xml +++ b/test/unit/sample_files/write_init_files/simple_reg.xml @@ -22,6 +22,7 @@ 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..ed17d094 100644 --- a/test/unit/test_build_cache.py +++ b/test/unit/test_build_cache.py @@ -449,7 +449,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_hist_config.py b/test/unit/test_hist_config.py new file mode 100644 index 00000000..fa5435f6 --- /dev/null +++ b/test/unit/test_hist_config.py @@ -0,0 +1,229 @@ +#! /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 sys +import unittest + +__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__) + +if not os.path.exists(__CIME_CONFIG_DIR): + raise ImportError(f"Cannot find '{__CIME_CONFIG_DIR}'") + +if not os.path.exists(_SAMPLE_FILES_DIR): + raise ImportError(f"Cannot find '{_SAMPLE_FILES_DIR}'") + +sys.path.append(__CIME_CONFIG_DIR) + +# pylint: disable=wrong-import-position +from hist_config import HistoryConfig +from hist_config import HistoryConfigError +# 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, write_nstep0, filename_spec, restart_fname_spec): + """Check the properties of against the other inputs: + : volume + : precision + : max_frames + : output_frequency + : file_type + : flag to write the 0th timestep + : filename template + : restart filename template + """ + 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") + self.assertEqual(config.write_nstep0, write_nstep0, msg="Bad write_nstep0 flag") + self.assertEqual(config.filename_spec, filename_spec, msg="Bad filename spec") + self.assertEqual(config.restart_fname_spec, restart_fname_spec, msg="Bad restart filename spec") + + 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 + hist_log = logging.getLogger("hist_log") + #_LOGGER.setLevel(logging.DEBUG) + with self.assertLogs(hist_log, level='DEBUG') as cmplog: + hist_configs = HistoryConfig(filename=in_source, logger=hist_log) + # end with + # Check that the first few lines of the log are as expected + expected_logmsg = ["DEBUG:hist_log:Added average field, 'MOE' to hist volume, h1, at", + "DEBUG:hist_log:Added average field, 'LARRY' to hist volume, h1, at", + "DEBUG:hist_log:Added average field, 'CURLY' to hist volume, h1, at"] + for index, expected_log in enumerate(expected_logmsg): + self.assertTrue(cmplog.output[index].startswith(expected_log)) + # end for + # 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 = 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") + hconfig = hist_configs['h1'] + self._test_config(hconfig, 'h1', 'REAL32', 30, (14, 'hours'), 'history', '.false.', '%c.cam.%u%f.%y-%m-%d-%s.nc', '%c.cam.r%u.%y-%m-%d-%s.nc') + 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', '.false.', '%c.cam.%u%f.%y-%m-%d-%s.nc', '%c.cam.r%u.%y-%m-%d-%s.nc') + _LOGGER.setLevel(logging.DEBUG) + # 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, logger=_LOGGER) + # end for + # end with + # Make sure each output file was created + amsg = f"{out_source} does not exist" + self.assertTrue(os.path.exists(out_source), msg=amsg) + # Make sure the output file is correct + amsg = f"{out_source} does not match {out_test}" + 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 = 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") + hconfig = hist_configs['h0'] + self._test_config(hconfig, 'h0', 'REAL32', 1, (1, 'nmonths'), 'history', '.false.', '%c.cam.%u%f.%y-%m-%d-%s.nc', '%c.cam.r%u.%y-%m-%d-%s.nc') + 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', '.true.', 'test_fname_%y.nc', '%c.cam.r%u.%y-%m-%d-%s.nc') + # 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, logger=_LOGGER) + # end for + # end with + # Make sure each output file was created + amsg = f"{out_source} does not exist" + self.assertTrue(os.path.exists(out_source), msg=amsg) + # Make sure the output file is correct + amsg = f"{out_source} does not match {out_test}" + self.assertTrue(filecmp.cmp(out_test, out_source, shallow='.false.'), + msg=amsg) + + def test_bad_user_nl_cam(self): + """Test invalid history entries; confirm correct errors are thrown""" + # Setup test + in_source = os.path.join(_SAMPLE_FILES_DIR, "user_nl_cam_multi") + modified_in_source = os.path.join(_TMP_DIR, "user_nl_cam_multi_bad") + 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]) + + # Open good user_nl_cam from previous test + with open(in_source, "r", encoding="utf-8") as old_file: + # Read in file: + file_lines = old_file.readlines() + # Edit to add bad lines + file_lines[8] = "" + file_lines[9] = "hist_remove_fields;h0:\n" + file_lines[10] = "hist_output_frequency;h0: 1+nmonths\n" + file_lines[11] = "hist_precision;h0: REAL34\n" + file_lines[13] = "hist_add_inst_fields;h3: T&U&V\n" + file_lines[16] = "hist_max_frames;h3: -24\n" + file_lines[17] = "hist_write_nstep0;h3: treu\n" + # end with + + # Create a new modified version of the file with the bad entries + with open(modified_in_source, "w", encoding="utf-8") as new_file: + # Write lines to new file + new_file.writelines(file_lines) + # end with + + # Run test + with self.assertRaises(HistoryConfigError) as err: + hist_configs = HistoryConfig(filename=modified_in_source, logger=_LOGGER) + # end with + + exception_split = str(err.exception).split('\n') + errmsg_expected = ["No identifiers found, at", + "period (\"1+nmonths\") 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, at", + "precision must be one of REAL32, REAL64, at", + "Found invalid identifiers", + "T&U&V, at", + "Attempt to set max frames to '-24', must be a positive integer, at", + "hist_write_nstep0 must be one of .false., .true., f, false, t, true, at"] + + # Check error messages are as expected + for index, errmsg in enumerate(exception_split): + self.assertTrue(errmsg.strip().startswith(errmsg_expected[index])) + # end for + + +############################################################################## + +if __name__ == '__main__': + unittest.main() 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,