diff --git a/CMakeLists.txt b/CMakeLists.txt index e0316793..c0aa6cee 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -20,6 +20,7 @@ option(CCPP_RUN_ADVECTION_TEST "Enable advection regression test" OFF) option(CCPP_RUN_CAPGEN_TEST "Enable capgen regression test" OFF) option(CCPP_RUN_DDT_HOST_TEST "Enable ddt host regression test" OFF) option(CCPP_RUN_VAR_COMPATIBILITY_TEST "Enable variable compatibility regression test" OFF) +option(CCPP_RUN_NESTED_SUITE_TEST "Enable nested suite regression test" OFF) message("") message("OPENMP .............................. ${OPENMP}") @@ -31,6 +32,7 @@ message("CCPP_RUN_ADVECTION_TEST ............. ${CCPP_RUN_ADVECTION_TEST}") message("CCPP_RUN_CAPGEN_TEST ................ ${CCPP_RUN_CAPGEN_TEST}") message("CCPP_RUN_DDT_HOST_TEST .............. ${CCPP_RUN_DDT_HOST_TEST}") message("CCPP_RUN_VAR_COMPATIBILITY_TEST ..... ${CCPP_RUN_VAR_COMPATIBILITY_TEST}") +message("CCPP_RUN_NESTED_SUITE_TEST .......... ${CCPP_RUN_NESTED_SUITE_TEST}") message("") set(CCPP_VERBOSITY "0" CACHE STRING "Verbosity level of output (default: 0)") diff --git a/schema/suite_v1_0.xsd b/schema/suite_v1_0.xsd index 121438ed..dfa96cc5 100644 --- a/schema/suite_v1_0.xsd +++ b/schema/suite_v1_0.xsd @@ -26,7 +26,7 @@ - + diff --git a/schema/suite_v2_0.xsd b/schema/suite_v2_0.xsd new file mode 100644 index 00000000..51afeece --- /dev/null +++ b/schema/suite_v2_0.xsd @@ -0,0 +1,150 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/scripts/ccpp_datafile.py b/scripts/ccpp_datafile.py index 2318143e..e02061fc 100755 --- a/scripts/ccpp_datafile.py +++ b/scripts/ccpp_datafile.py @@ -25,7 +25,7 @@ from framework_env import CCPPFrameworkEnv from metadata_table import UNKNOWN_PROCESS_TYPE from metavar import Var -from parse_tools import read_xml_file, PrettyElementTree +from parse_tools import read_xml_file, write_xml_file from parse_tools import ParseContext, ParseSource from suite_objects import VerticalLoop, Subcycle @@ -1182,8 +1182,7 @@ def generate_ccpp_datatable(run_env, host_model, api, scheme_headers, # end for _add_dependencies(datatable, scheme_depends, host_depends) # Write tree - datatable_tree = PrettyElementTree(datatable) - datatable_tree.write(run_env.datatable_file) + write_xml_file(datatable, run_env.datatable_file) ############################################################################### diff --git a/scripts/ccpp_suite.py b/scripts/ccpp_suite.py index 9657a221..5f47c22d 100644 --- a/scripts/ccpp_suite.py +++ b/scripts/ccpp_suite.py @@ -19,7 +19,8 @@ from metavar import Var, VarDictionary, ccpp_standard_var from parse_tools import ParseContext, ParseSource from parse_tools import ParseInternalError, CCPPError -from parse_tools import read_xml_file, validate_xml_file, find_schema_version +from parse_tools import read_xml_file, validate_xml_file, write_xml_file +from parse_tools import find_schema_version, expand_nested_suites from parse_tools import init_log, set_log_to_null from suite_objects import CallList, Group, Scheme from metavar import CCPP_LOOP_VAR_STDNAMES @@ -82,7 +83,7 @@ class Suite(VarDictionary): __scheme_template = '{}' - def __init__(self, filename, api, run_env): + def __init__(self, filename, suite_xml, api, run_env): """Initialize this Suite object from the SDF, . serves as the Suite's parent.""" self.__run_env = run_env @@ -114,7 +115,7 @@ def __init__(self, filename, api, run_env): raise CCPPError(emsg.format(self.__sdf_name)) # end if # Parse the SDF - self.parse(run_env) + self.parse(suite_xml, run_env) @property def name(self): @@ -186,27 +187,13 @@ def new_group_from_name(self, group_name, run_env): group_xml = ''.format(group_name) return self.new_group(group_xml, group_name, run_env) - def parse(self, run_env): + def parse(self, suite_xml, run_env): """Parse the suite definition file.""" success = True - - _, suite_xml = read_xml_file(self.__sdf_name, run_env.logger) # We do not have line number information for the XML file self.__context = ParseContext(filename=self.__sdf_name) - # Validate the XML file - version = find_schema_version(suite_xml) - res = validate_xml_file(self.__sdf_name, 'suite', version, - run_env.logger) - if not res: - emsg = "Invalid suite definition file, '{}'" - raise CCPPError(emsg.format(self.__sdf_name)) - # end if self.__name = suite_xml.get('name') self.__module = 'ccpp_{}_cap'.format(self.name) - lmsg = "Reading suite definition file for '{}'" - if run_env.logger and run_env.logger.isEnabledFor(logging.INFO): - run_env.logger.info(lmsg.format(self.name)) - # end if gname = Suite.__register_group_name self.__suite_reg_group = self.new_group_from_name(gname, run_env) gname = Suite.__initial_group_name @@ -681,13 +668,43 @@ def __init__(self, sdfs, host_model, scheme_headers, run_env): raise CCPPError(errmsg.format(header.title)) # end if # end for + # Turn the SDF files into Suites for sdf in sdfs: - suite = Suite(sdf, self, run_env) - suite.analyze(self.host_model, scheme_library, - self.__ddt_lib, run_env) - self.__suites.append(suite) + # Load the suite definition file to determine the schema version, + # validate the file, and expand nested suites if applicable + _, xml_root = read_xml_file(sdf, run_env.logger) + # We do not have line number information for the XML file + self.__context = ParseContext(filename=sdf) + # Validate the XML file + schema_version = find_schema_version(xml_root) + res = validate_xml_file(sdf, 'suite', schema_version, run_env.logger) + if not res: + raise CCPPError(f"Invalid suite definition file, '{sdf}'") + + # Write the expanded sdf to the capgen output directory. + # This file isn't used by capgen (everything is in memory + # from here onwards), but it is useful for developers/users + # (although the output can also be found in the datatable). + (sdf_path, sdf_name) = os.path.split(sdf) + sdf_expanded = os.path.join(run_env.output_dir, + sdf_name.replace(".xml", "_expanded.xml")) + if schema_version[0] in [1, 2]: + # Preprocess the sdf to expand nested suites + if schema_version[0] == 2: + expand_nested_suites(xml_root, sdf_path, logger=run_env.logger) + write_xml_file(xml_root, sdf_expanded, run_env.logger) + suite = Suite(sdf, xml_root, self, run_env) + suite.analyze(self.host_model, scheme_library, + self.__ddt_lib, run_env) + self.__suites.append(suite) + else: + errmsg = f"Suite XML schema not supported: " + \ + "root={xml_root.tag}, version={schema_version}" + raise CCPPError(errmsg) + # end if # end for + # We will need the correct names for errmsg and errcode evar = self.host_model.find_variable(standard_name='ccpp_error_message') if evar is not None: diff --git a/scripts/parse_tools/__init__.py b/scripts/parse_tools/__init__.py index bfd2cfbf..6590e3f7 100644 --- a/scripts/parse_tools/__init__.py +++ b/scripts/parse_tools/__init__.py @@ -30,7 +30,7 @@ from preprocess import PreprocStack from xml_tools import find_schema_file, find_schema_version from xml_tools import read_xml_file, validate_xml_file -from xml_tools import PrettyElementTree +from xml_tools import expand_nested_suites, write_xml_file from fortran_conditional import FORTRAN_CONDITIONAL_REGEX_WORDS, FORTRAN_CONDITIONAL_REGEX # pylint: enable=wrong-import-position @@ -51,6 +51,7 @@ 'check_valid_values', 'check_molar_mass', 'context_string', + 'expand_nested_suites', 'find_schema_file', 'find_schema_version', 'flush_log', @@ -65,7 +66,6 @@ 'ParseSyntaxError', 'ParseObject', 'PreprocStack', - 'PrettyElementTree', 'read_xml_file', 'register_fortran_ddt_name', 'registered_fortran_ddt_name', @@ -78,6 +78,7 @@ 'type_name', 'unique_standard_name', 'validate_xml_file', + 'write_xml_file', 'FORTRAN_CONDITIONAL_REGEX_WORDS', 'FORTRAN_CONDITIONAL_REGEX' ] diff --git a/scripts/parse_tools/xml_tools.py b/scripts/parse_tools/xml_tools.py index 164b169b..ba3a5d57 100644 --- a/scripts/parse_tools/xml_tools.py +++ b/scripts/parse_tools/xml_tools.py @@ -12,6 +12,7 @@ import subprocess import sys import xml.etree.ElementTree as ET +import xml.dom.minidom sys.path.insert(0, os.path.dirname(__file__)) # CCPP framework imports from parse_source import CCPPError @@ -225,7 +226,19 @@ def validate_xml_file(filename, schema_root, version, logger, ############################################################################### def read_xml_file(filename, logger=None): ############################################################################### - """Read the XML file, , and return its tree and root""" + """Read the XML file, , and return its tree and root + + Parameters: + filename (str): The path to an XML file to read and search. + logger (logging.Logger, optional): Logger for warnings/errors. + + Returns: + tree (xml.etree.ElementTreet): The element tree from the input file. + root (xml.etree.ElementTree.Element): The root element of tree. + + Raises: + CCPPError: If the file cannot be found or read. + """ if os.path.isfile(filename) and os.access(filename, os.R_OK): file_open = (lambda x: open(x, 'r', encoding='utf-8')) with file_open(filename) as file_: @@ -242,101 +255,368 @@ def read_xml_file(filename, logger=None): raise CCPPError(emsg.format(filename)) # end if if logger: - logger.debug("Read XML file, '{}'".format(filename)) + logger.debug(f"Reading XML file {filename}") # end if return tree, root ############################################################################### +def load_suite_by_name(suite_name, group_name, file, logger=None): +############################################################################### + """ + Load a suite by its name, or a group of a suite by the suite and group names. -class PrettyElementTree(ET.ElementTree): - """An ElementTree subclass with nice formatting when writing to a file""" + Parameters: + suite_name (str): The name of the suite to find. + group_name (str or None): The name of the group to find within the suite. + file (str): The path to an XML file to read and search. + logger (logging.Logger, optional): Logger for warnings/errors. - def __init__(self, element=None, file=None): - """Initialize a PrettyElementTree object""" - super().__init__(element, file) + Returns: + xml.etree.ElementTree.Element: The matching suite or group element. - def _write(self, outfile, line, indent, eol=os.linesep): - """Write as an ASCII string to """ - outfile.write('{}{}{}'.format(_INDENT_STR*indent, line, eol)) + Raises: + CCPPError: If the suite or group is not found, or if the schema is invalid. - @staticmethod - def _inc_pos(outstr, text, txt_beg): - """Return a position increment based on the length of - or raise an exception if is empty. - and are used to provide some context for the error.""" - if outstr: - return len(outstr) - # end if - txt_end = text[txt_beg].find(">") + txt_beg + 1 - if txt_end <= txt_beg: - txt_end = txt_beg + 256 - # end if - emsg = "No output at {} of {}\n{}".format(txt_beg, len(text), - text[txt_beg:txt_end]) - raise XMLToolsInternalError(emsg) - - def write(self, file, encoding="us-ascii", xml_declaration=None, - default_namespace=None, method="xml", - short_empty_elements=True): - """Subclassed write method to format output.""" - et_str = ET.tostring(self.getroot(), - encoding=encoding, method=method, - xml_declaration=xml_declaration, - default_namespace=default_namespace, - short_empty_elements=short_empty_elements) - # end if - fmode = 'wt' - root = str(et_str, encoding="utf-8") - indent = 0 - last_write_text = False - with open(file, fmode) as outfile: - inline = root.strip() - istart = 0 # Current start pos - iend = len(inline) - while istart < iend: - bmatch = beg_tag_re.match(inline[istart:]) - ematch = end_tag_re.match(inline[istart:]) - smatch = simple_tag_re.match(inline[istart:]) - if bmatch is not None: - outstr = bmatch.group(1) - if inline[istart + len(bmatch.group(1))] != '<': - # Print text on same line - self._write(outfile, outstr, indent, eol='') - else: - self._write(outfile, outstr, indent) - # end if - indent += 1 - istart += self._inc_pos(outstr, inline, istart) - last_write_text = False - elif ematch is not None: - outstr = ematch.group(1) - indent -= 1 - if last_write_text: - self._write(outfile, outstr, 0) - last_write_text = False - else: - self._write(outfile, outstr, indent) - # end if - istart += self._inc_pos(outstr, inline, istart) - elif smatch is not None: - outstr = smatch.group(1) - self._write(outfile, outstr, indent) - istart += self._inc_pos(outstr, inline, istart) - last_write_text = False - else: - # No tag, just output text - end_index = inline[istart:].find('<') - if end_index < 0: - end_index = iend - else: - end_index += istart - # end if - outstr = inline[istart:end_index] - self._write(outfile, outstr.strip(), 0, eol='') - last_write_text = True - istart += self._inc_pos(outstr, inline, istart) - # end if - # end while - # end with + Examples: + >>> import tempfile + >>> import xml.etree.ElementTree as ET + >>> logger = init_log('xml_tools') + >>> # Create temporary files for the nested suites + >>> tmpdir = tempfile.TemporaryDirectory() + >>> file1_path = os.path.join(tmpdir.name, "file1.xml") + >>> # Write XML contents to temporary file + >>> with open(file1_path, "w") as f: + ... _ = f.write(''' + ... + ... + ... + ... + ... ''') + >>> load_suite_by_name("physics_suite", None, file1_path, logger).tag + 'suite' + >>> load_suite_by_name("physics_suite", "dynamics", file1_path, logger).attrib['name'] + 'dynamics' + >>> load_suite_by_name("physics_suite", "missing_group", file1_path, logger) #doctest: +IGNORE_EXCEPTION_DETAIL + Traceback (most recent call last): + ... + CCPPError: Nested suite physics_suite, group missing_group, not found + >>> load_suite_by_name("missing_suite", None, file1_path, logger) #doctest: +IGNORE_EXCEPTION_DETAIL + Traceback (most recent call last): + ... + CCPPError: Nested suite missing_suite not found + >>> tmpdir.cleanup() + """ + _, root = read_xml_file(file, logger) + schema_version = find_schema_version(root) + if schema_version[0] < 2: + raise CCPPError(f"XML schema version {schema_version} " + \ + f"invalid for nested suite {suite_name}") + res = validate_xml_file(file, 'suite', schema_version, logger) + if not res: + raise CCPPError(f"Invalid suite definition file, '{sdf}'") + suite = root + if suite.attrib.get("name") == suite_name: + if group_name: + for group in suite.findall("group"): + if group.attrib.get("name") == group_name: + return group + else: + return suite + emsg = f"Nested suite {suite_name}" \ + + (f", group {group_name}," if group_name else "") \ + + " not found" + (f" in file {file}" if file else "") + raise CCPPError(emsg) + +############################################################################### +def replace_nested_suite(element, nested_suite, default_path, logger): +############################################################################### + """ + Replace a tag with the actual suite or group it references. + + This function looks up a referenced suite or suite group from an external + file, deep copies its children, and replaces the element + in the parent `element` with the copied contents. + + Parameters: + element (xml.etree.ElementTree.Element): The parent element containing the nested suite. + nested_suite (xml.etree.ElementTree.Element): The element to be replaced. + default_path (str): The default path to look for nested SDFs if file is not a absolute path. + logger (logging.Logger or None): Logger to record debug information. + + Returns: + str: The name of the suite that was replaced + + Example: + >>> import tempfile + >>> import xml.etree.ElementTree as ET + >>> from types import SimpleNamespace + >>> logger = init_log('xml_tools') + >>> tmpdir = tempfile.TemporaryDirectory() + >>> file1_path = os.path.join(tmpdir.name, "file1.xml") + >>> with open(file1_path, "w") as f: + ... _ = f.write(''' + ... + ... + ... my_scheme + ... + ... + ... ''') + >>> # Import nested suite at suite level + >>> xml = f''' + ... + ... + ... + ... ''' + >>> top_suite = ET.fromstring(xml) + >>> nested = top_suite.find("nested_suite") + >>> replace_nested_suite(top_suite, nested, tmpdir.name, logger) + 'my_suite' + >>> [child.tag for child in top_suite] + ['group'] + >>> top_suite.find("group").find("scheme").text + 'my_scheme' + >>> # Import group from nested suite at group level + >>> xml = f''' + ... + ... + ... + ... + ... + ... ''' + >>> top_suite = ET.fromstring(xml) + >>> top_group = top_suite.find("group") + >>> nested = top_group.find("nested_suite") + >>> replace_nested_suite(top_group, nested, tmpdir.name, logger) + 'my_suite' + >>> [child.tag for child in top_suite] + ['group'] + >>> top_suite.find("group").find("scheme").text + 'my_scheme' + >>> # Import group from nested suite at suite level + >>> xml = f''' + ... + ... + ... + ... ''' + >>> top_suite = ET.fromstring(xml) + >>> nested = top_suite.find("nested_suite") + >>> replace_nested_suite(top_suite, nested, tmpdir.name, logger) + 'my_suite' + >>> [child.tag for child in top_suite] + ['group'] + >>> top_suite.find("group").find("scheme").text + 'my_scheme' + >>> tmpdir.cleanup() + """ + suite_name = nested_suite.attrib.get("name") + group_name = nested_suite.attrib.get("group") + file = nested_suite.attrib.get("file") + if not os.path.isabs(file): + file = os.path.join(default_path, file) + referenced_suite = load_suite_by_name(suite_name, group_name, file, + logger=logger) + imported_content = [ET.fromstring(ET.tostring(child)) + for child in referenced_suite] + # Swap nested suite with imported content + for item in imported_content: + # If the imported content comes from a separate file and has + # nested suites that are within that separate file, then we + # need to inject the file attribute here. + if item.tag == "nested_suite": + if file and not item.attrib.get("file"): + item.set("file", file) + # If we are inserting a nested suite at the suite level (element.tag is suite), + # but we only want one group (group_name is not none), then we need to wrap + # the item in a group element. If on the other hand we insert an entire suite + # (all groups) at the suite level, or a specific group at the group level, + # then we can insert the item as is. + if element.tag == 'suite' and group_name: + item_to_insert = ET.Element("group", attrib={"name": group_name}) + item_to_insert.append(item) + else: + item_to_insert = item + element.insert(list(element).index(nested_suite), item_to_insert) + element.remove(nested_suite) + if logger: + msg = f"Expanded nested suite '{suite_name}'" \ + + (f", group '{group_name}'," if group_name else "") \ + + (f" in file '{file}'" if file else "") + logger.debug(msg.rstrip(',')) + # Return the name of the suite that we just replaced + return suite_name + +############################################################################### +def expand_nested_suites(suite, default_path, logger=None): +############################################################################### + """ + Recursively expand all elements within the XML element. + + This function finds elements within or elements, + and replaces them with the corresponding content from another suite. + + This operation is recursive and will continue expanding until no + elements remain. + + Parameters: + suite (xml.etree.ElementTree.Element): The root element. + logger (logging.Logger, optional): Logger for debug messages. + + Returns: + None. The XML tree is modified in place. + + Example: + >>> import tempfile + >>> import xml.etree.ElementTree as ET + >>> logger = init_log('xml_tools') + >>> tmpdir = tempfile.TemporaryDirectory() + >>> file1_path = os.path.join(tmpdir.name, "file1.xml") + >>> file2_path = os.path.join(tmpdir.name, "file2.xml") + >>> file3_path = os.path.join(tmpdir.name, "file3.xml") + >>> file4_path = os.path.join(tmpdir.name, "file4.xml") + >>> file5_path = os.path.join(tmpdir.name, "file5.xml") + >>> # Write mock XML contents for the nested suites + >>> with open(file1_path, "w") as f: + ... _ = f.write(''' + ... + ... + ... cloud_scheme + ... + ... + ... ''') + >>> with open(file2_path, "w") as f: + ... _ = f.write(''' + ... + ... + ... pbl_scheme + ... + ... + ... ''') + >>> with open(file3_path, "w") as f: + ... _ = f.write(''' + ... + ... + ... rrtmg_lw_scheme + ... + ... + ... rrtmg_sw_scheme + ... + ... + ... ''') + >>> with open(file4_path, "w") as f: + ... _ = f.write(f''' + ... + ... + ... + ... ''') + >>> with open(file5_path, "w") as f: + ... _ = f.write(f''' + ... + ... + ... + ... ''') + >>> # Parent suite + >>> xml_content = f''' + ... + ... + ... + ... + ... + ... + ... + ... ''' + >>> suite = ET.fromstring(xml_content) + >>> expand_nested_suites(suite, tmpdir.name, logger) + >>> ET.dump(suite) + + + cloud_scheme + + pbl_scheme + + rrtmg_lw_scheme + + rrtmg_sw_scheme + + >>> # Test infite recursion + >>> xml_content = f''' + ... + ... + ... + ... + ... + ... + ... ''' + >>> suite = ET.fromstring(xml_content) + >>> expand_nested_suites(suite, tmpdir.name, logger) #doctest: +IGNORE_EXCEPTION_DETAIL + Traceback (most recent call last): + ... + CCPPError: Exceeded number of iterations while expanding nested suites + >>> tmpdir.cleanup() + """ + # To avoid infinite recursion, we simply count the number + # of iterations and stop at a certain limit. If someone is + # smart enough to come up with nested suite constructs that + # require more iterations, than he/she should be able to + # track down this variable and adjust it! + max_iterations = 10 + # Collect the names of the expanded suites + suite_names = [] + # Iteratively expand nested suites until they are all gone + keep_expanding = True + for num_iterations in range(max_iterations): + keep_expanding = False + # First, search all groups for nested_suite elements + groups = suite.findall("group") + for group in groups: + nested_suites = group.findall("nested_suite") + for nested in nested_suites: + suite_names.append(replace_nested_suite(group, nested, default_path, logger)) + # Trigger another pass over the root element + keep_expanding = True + # Second, search all suites for nested_suite elements + nested_suites = suite.findall("nested_suite") + for nested in nested_suites: + suite_names.append(replace_nested_suite(suite, nested, default_path, logger)) + # Trigger another pass over the root element + keep_expanding = True + if not keep_expanding: + return + raise CCPPError("Exceeded number of iterations while expanding nested suites:" + \ + "check for inifite recursion or adjust limit max_iterations." + \ + f"Suites expanded so far: {suite_names}") + +############################################################################### +def write_xml_file(root, file_path, logger=None): +############################################################################### + """Pretty-prints element root to an ASCII file using xml.dom.minidom""" + + def remove_whitespace_nodes(node): + """Helper function to recursively remove all text nodes that contain + only whitespace, which eliminates blank lines in the output.""" + for child in list(node.childNodes): + if child.nodeType == child.TEXT_NODE and not child.data.strip(): + node.removeChild(child) + elif child.hasChildNodes(): + remove_whitespace_nodes(child) + + # Convert ElementTree to a byte string + byte_string = ET.tostring(root, 'us-ascii') + + # Parse string using minidom for pretty printing + reparsed = xml.dom.minidom.parseString(byte_string) + + # Clean whitespace-only text nodes + remove_whitespace_nodes(reparsed) + + # Generate pretty-printed XML string + pretty_xml = reparsed.toprettyxml(indent=" ") + + # Write to file + with open(file_path, 'w', errors='xmlcharrefreplace') as f: + f.write(pretty_xml) + + # Tell everyone! + if logger: + logger.debug(f"Writing XML file {file_path}") ############################################################################## diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 5666599d..342ddad8 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -12,3 +12,6 @@ endif() if(CCPP_FRAMEWORK_ENABLE_TESTS OR CCPP_RUN_VAR_COMPATIBILITY_TEST) add_subdirectory(var_compatibility_test) endif() +if(CCPP_FRAMEWORK_ENABLE_TESTS OR CCPP_RUN_NESTED_SUITE_TEST) + add_subdirectory(nested_suite_test) +endif() diff --git a/test/nested_suite_test/CMakeLists.txt b/test/nested_suite_test/CMakeLists.txt new file mode 100644 index 00000000..491a8fb4 --- /dev/null +++ b/test/nested_suite_test/CMakeLists.txt @@ -0,0 +1,50 @@ + +#------------------------------------------------------------------------------ +# +# Create list of SCHEME_FILES, HOST_FILES, and SUITE_FILES +# Paths should be relative to CMAKE_SOURCE_DIR (this file's directory) +# +#------------------------------------------------------------------------------ +set(SCHEME_FILES "effr_calc" "effrs_calc" "effr_diag" "effr_pre" "effr_post" "rad_lw" "rad_sw") +set(HOST_FILES "module_rad_ddt" "test_host_data" "test_host_mod") +set(SUITE_FILES "main_suite.xml") +# HOST is the name of the executable we will build. +# We assume there are files ${HOST}.meta and ${HOST}.F90 in CMAKE_SOURCE_DIR +set(HOST "test_host") + +# By default, generated caps go in ccpp subdir +set(CCPP_CAP_FILES "${CMAKE_CURRENT_BINARY_DIR}/ccpp") + +# Create lists for Fortran and meta data files from file names +list(TRANSFORM SCHEME_FILES APPEND ".F90" OUTPUT_VARIABLE SCHEME_FORTRAN_FILES) +list(TRANSFORM SCHEME_FILES APPEND ".meta" OUTPUT_VARIABLE SCHEME_META_FILES) +list(TRANSFORM HOST_FILES APPEND ".F90" OUTPUT_VARIABLE NESTED_SUITE_HOST_FORTRAN_FILES) +list(TRANSFORM HOST_FILES APPEND ".meta" OUTPUT_VARIABLE NESTED_SUITE_HOST_METADATA_FILES) + +list(APPEND NESTED_SUITE_HOST_METADATA_FILES "${HOST}.meta") + +# Run ccpp_capgen +ccpp_capgen(CAPGEN_DEBUG ON + VERBOSITY ${CCPP_VERBOSITY} + HOSTFILES ${NESTED_SUITE_HOST_METADATA_FILES} + SCHEMEFILES ${SCHEME_META_FILES} + SUITES ${SUITE_FILES} + HOST_NAME ${HOST} + OUTPUT_ROOT "${CCPP_CAP_FILES}") + +# Retrieve the list of Fortran files required for test host from datatable.xml and set to CCPP_CAPS_LIST +ccpp_datafile(DATATABLE "${CCPP_CAP_FILES}/datatable.xml" + REPORT_NAME "--ccpp-files") + +# Create test host library +add_library(NESTED_SUITE_TESTLIB OBJECT ${SCHEME_FORTRAN_FILES} + ${NESTED_SUITE_HOST_FORTRAN_FILES} + ${CCPP_CAPS_LIST}) + +# Setup test executable with needed dependencies +add_executable(nested_suite_host_integration test_nested_suite_integration.F90 ${HOST}.F90) +target_link_libraries(nested_suite_host_integration PRIVATE NESTED_SUITE_TESTLIB test_utils) +target_include_directories(nested_suite_host_integration PRIVATE "$") + +# Add executable to be called with ctest +add_test(NAME ctest_nested_suite_host_integration COMMAND nested_suite_host_integration) diff --git a/test/nested_suite_test/README.md b/test/nested_suite_test/README.md new file mode 100644 index 00000000..0c2033db --- /dev/null +++ b/test/nested_suite_test/README.md @@ -0,0 +1,18 @@ +# Nested Suite Test + +Tests the capability to process nested suites: +- Inherited from the variable compatibility test as of 2025/10/01 + - Perform same tests as variable compatibility test at that date +- Parse new XML schema 2.0 +- Expand nested suites at the group level and inside groups + +## Building/Running + +To explicitly build/run the nested suite test host, run: + +```bash +$ cmake -S -B -DCCPP_RUN_NESTED_SUITE_TEST=ON +$ cd +$ make +$ ctest +``` diff --git a/test/nested_suite_test/ccpp_kinds.F90 b/test/nested_suite_test/ccpp_kinds.F90 new file mode 100644 index 00000000..b2923935 --- /dev/null +++ b/test/nested_suite_test/ccpp_kinds.F90 @@ -0,0 +1,27 @@ +! +! This work (Common Community Physics Package Framework), identified by +! NOAA, NCAR, CU/CIRES, is free of known copyright restrictions and is +! placed in the public domain. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +!> +!! @brief Auto-generated kinds for CCPP +!! +! +module ccpp_kinds + + use ISO_FORTRAN_ENV, only: kind_phys => REAL64 + + implicit none + private + + public :: kind_phys + +end module ccpp_kinds diff --git a/test/nested_suite_test/effr_calc.F90 b/test/nested_suite_test/effr_calc.F90 new file mode 100644 index 00000000..0b626c16 --- /dev/null +++ b/test/nested_suite_test/effr_calc.F90 @@ -0,0 +1,84 @@ +!Test unit conversions for intent in, inout, out variables +! + +module effr_calc + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + + contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind_phys), intent(in) :: effrr_in(:,:) + real(kind_phys), intent(in),optional :: effrg_in(:,:) + real(kind_phys), intent(in),optional :: ncg_in(:,:) + real(kind_phys), intent(out),optional :: nci_out(:,:) + real(kind_phys), intent(inout) :: effrl_inout(:,:) + real(kind_phys), intent(out),optional :: effri_out(:,:) + real(8),intent(inout) :: effrs_inout(:,:) + logical, intent(in) :: has_graupel + real(kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind_phys), intent(out),optional :: ncl_out(:,:) + real(kind_phys), intent(inout) :: tke_inout + real(kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind_phys) :: effrr_local(ncol,nlev) + real(kind_phys) :: effrg_local(ncol,nlev) + real(kind_phys) :: ncg_in_local(ncol,nlev) + real(kind_phys) :: nci_out_local(ncol,nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run + +end module effr_calc diff --git a/test/nested_suite_test/effr_calc.meta b/test/nested_suite_test/effr_calc.meta new file mode 100644 index 00000000..c3733f13 --- /dev/null +++ b/test/nested_suite_test/effr_calc.meta @@ -0,0 +1,163 @@ +[ccpp-table-properties] + name = effr_calc + type = scheme + dependencies = +######################################################################## +[ccpp-arg-table] + name = effr_calc_init + type = scheme +[ scheme_order ] + standard_name = scheme_order_in_suite + long_name = scheme order in suite definition file + units = None + dimensions = () + type = integer + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +######################################################################## +[ccpp-arg-table] + name = effr_calc_run + type = scheme +[ ncol ] + standard_name = horizontal_loop_extent + type = integer + units = count + dimensions = () + intent = in +[ nlev ] + standard_name = vertical_layer_dimension + type = integer + units = count + dimensions = () + intent = in +[effrr_in] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + top_at_one = True +[effrg_in] + standard_name = effective_radius_of_stratiform_cloud_graupel + long_name = effective radius of cloud graupel in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = True +[ncg_in] + standard_name = cloud_graupel_number_concentration + long_name = number concentration of cloud graupel + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = True +[nci_out] + standard_name = cloud_ice_number_concentration + long_name = number concentration of cloud ice + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out + optional = True +[effrl_inout] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle + long_name = effective radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[effri_out] + standard_name = effective_radius_of_stratiform_cloud_ice_particle + long_name = effective radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out + optional = True +[effrs_inout] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + long_name = effective radius of cloud snow particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = 8 + intent = inout + top_at_one = True +[ncl_out] + standard_name = cloud_liquid_number_concentration + long_name = number concentration of cloud liquid + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out + optional = True +[has_graupel] + standard_name = flag_indicating_cloud_microphysics_has_graupel + long_name = flag indicating that the cloud microphysics produces graupel + units = flag + dimensions = () + type = logical + intent = in +[ scalar_var ] + standard_name = scalar_variable_for_testing + long_name = scalar variable for testing + units = km + dimensions = () + type = real + kind = kind_phys + intent = inout +[ tke_inout ] + standard_name = turbulent_kinetic_energy + long_name = turbulent_kinetic_energy + units = m2 s-2 + dimensions = () + type = real + kind = kind_phys + intent = inout +[ tke2_inout ] + standard_name = turbulent_kinetic_energy2 + long_name = turbulent_kinetic_energy2 + units = m+2 s-2 + dimensions = () + type = real + kind = kind_phys + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/effr_diag.F90 b/test/nested_suite_test/effr_diag.F90 new file mode 100644 index 00000000..409ff2f9 --- /dev/null +++ b/test/nested_suite_test/effr_diag.F90 @@ -0,0 +1,68 @@ +!Test unit conversions for intent in, inout, out variables +! + +module effr_diag + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_diag_run, effr_diag_init + +contains + + !> \section arg_table_effr_diag_init Argument Table + !! \htmlinclude arg_table_effr_diag_init.html + !! + subroutine effr_diag_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_diag_init + + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) + + real(kind_phys), intent(in) :: effrr_in(:,:) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var .ne. 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + endif + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind_phys), intent(in) :: effr(:,:) + real(kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag +end module effr_diag diff --git a/test/nested_suite_test/effr_diag.meta b/test/nested_suite_test/effr_diag.meta new file mode 100644 index 00000000..9e0e4fc2 --- /dev/null +++ b/test/nested_suite_test/effr_diag.meta @@ -0,0 +1,65 @@ +[ccpp-table-properties] + name = effr_diag + type = scheme + dependencies = +######################################################################## +[ccpp-arg-table] + name = effr_diag_init + type = scheme +[ scheme_order ] + standard_name = scheme_order_in_suite + long_name = scheme order in suite definition file + units = None + dimensions = () + type = integer + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +######################################################################## +[ccpp-arg-table] + name = effr_diag_run + type = scheme +[effrr_in] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + top_at_one = True +[ scalar_var ] + standard_name = scalar_variable_for_testing_c + long_name = unused scalar variable C + units = m + dimensions = () + type = integer + intent = in +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/effr_post.F90 b/test/nested_suite_test/effr_post.F90 new file mode 100644 index 00000000..d42a574c --- /dev/null +++ b/test/nested_suite_test/effr_post.F90 @@ -0,0 +1,61 @@ +!Test unit conversions for intent in, inout, out variables +! + +module effr_post + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_post_run, effr_post_init + +contains + + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + endif + + end subroutine effr_post_run + + end module effr_post diff --git a/test/nested_suite_test/effr_post.meta b/test/nested_suite_test/effr_post.meta new file mode 100644 index 00000000..721582a6 --- /dev/null +++ b/test/nested_suite_test/effr_post.meta @@ -0,0 +1,65 @@ +[ccpp-table-properties] + name = effr_post + type = scheme + dependencies = +######################################################################## +[ccpp-arg-table] + name = effr_post_init + type = scheme +[ scheme_order ] + standard_name = scheme_order_in_suite + long_name = scheme order in suite definition file + units = None + dimensions = () + type = integer + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +######################################################################## +[ccpp-arg-table] + name = effr_post_run + type = scheme +[effrr_inout] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometer + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ scalar_var ] + standard_name = scalar_variable_for_testing_b + long_name = unused scalar variable B + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/effr_pre.F90 b/test/nested_suite_test/effr_pre.F90 new file mode 100644 index 00000000..17a3b187 --- /dev/null +++ b/test/nested_suite_test/effr_pre.F90 @@ -0,0 +1,60 @@ +!Test unit conversions for intent in, inout, out variables +! + +module mod_effr_pre + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_pre_run, effr_pre_init + +contains + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + endif + + end subroutine effr_pre_run + +end module mod_effr_pre diff --git a/test/nested_suite_test/effr_pre.meta b/test/nested_suite_test/effr_pre.meta new file mode 100644 index 00000000..251b4175 --- /dev/null +++ b/test/nested_suite_test/effr_pre.meta @@ -0,0 +1,66 @@ +[ccpp-table-properties] + name = effr_pre + type = scheme + module_name = mod_effr_pre + dependencies = +######################################################################## +[ccpp-arg-table] + name = effr_pre_init + type = scheme +[ scheme_order ] + standard_name = scheme_order_in_suite + long_name = scheme order in suite definition file + units = None + dimensions = () + type = integer + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +######################################################################## +[ccpp-arg-table] + name = effr_pre_run + type = scheme +[effrr_inout] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometer + units = m + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ scalar_var ] + standard_name = scalar_variable_for_testing_a + long_name = unused scalar variable A + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/effrs_calc.F90 b/test/nested_suite_test/effrs_calc.F90 new file mode 100644 index 00000000..e9266905 --- /dev/null +++ b/test/nested_suite_test/effrs_calc.F90 @@ -0,0 +1,32 @@ +!Test unit conversions for intent in, inout, out variables +! + +module effrs_calc + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effrs_calc_run + + contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrs_inout(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + !---------------------------------------------------------------- + + errmsg = '' + errflg = 0 + + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + + end subroutine effrs_calc_run + +end module effrs_calc diff --git a/test/nested_suite_test/effrs_calc.meta b/test/nested_suite_test/effrs_calc.meta new file mode 100644 index 00000000..9ce7b88e --- /dev/null +++ b/test/nested_suite_test/effrs_calc.meta @@ -0,0 +1,25 @@ +[ccpp-table-properties] + name = effrs_calc + type = scheme + +[ccpp-arg-table] + name = effrs_calc_run + type = scheme +[ effrs_inout ] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + units = m + type = real | kind = kind_phys + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + units = none + type = character | kind = len=512 + dimensions = () + intent = out +[ errflg ] + standard_name = ccpp_error_code + units = 1 + type = integer + dimensions = () + intent = out diff --git a/test/nested_suite_test/main_suite.xml b/test/nested_suite_test/main_suite.xml new file mode 100644 index 00000000..a319ec47 --- /dev/null +++ b/test/nested_suite_test/main_suite.xml @@ -0,0 +1,18 @@ + + + + + + effr_pre + + + effr_calc + + + effr_post + + + + + + diff --git a/test/nested_suite_test/module_rad_ddt.F90 b/test/nested_suite_test/module_rad_ddt.F90 new file mode 100644 index 00000000..21a1a0ec --- /dev/null +++ b/test/nested_suite_test/module_rad_ddt.F90 @@ -0,0 +1,23 @@ +module mod_rad_ddt + USE ccpp_kinds, ONLY: kind_phys + implicit none + + public ty_rad_lw, ty_rad_sw + + !> \section arg_table_ty_rad_lw Argument Table + !! \htmlinclude arg_table_ty_rad_lw.html + !! + type ty_rad_lw + real(kind_phys) :: sfc_up_lw + real(kind_phys) :: sfc_down_lw + end type ty_rad_lw + + !> \section arg_table_ty_rad_sw Argument Table + !! \htmlinclude arg_table_ty_rad_sw.html + !! + type ty_rad_sw + real(kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind_phys), pointer :: sfc_down_sw(:) => null() + end type ty_rad_sw + +end module mod_rad_ddt diff --git a/test/nested_suite_test/module_rad_ddt.meta b/test/nested_suite_test/module_rad_ddt.meta new file mode 100644 index 00000000..c4792547 --- /dev/null +++ b/test/nested_suite_test/module_rad_ddt.meta @@ -0,0 +1,40 @@ +[ccpp-table-properties] + name = ty_rad_lw + type = ddt + dependencies = + module_name = mod_rad_ddt +[ccpp-arg-table] + name = ty_rad_lw + type = ddt +[ sfc_up_lw ] + standard_name = surface_upwelling_longwave_radiation_flux + units = W m2 + dimensions = () + type = real + kind = kind_phys +[ sfc_down_lw ] + standard_name = surface_downwelling_longwave_radiation_flux + units = W m2 + dimensions = () + type = real + kind = kind_phys + +[ccpp-table-properties] + name = ty_rad_sw + type = ddt + module_name = mod_rad_ddt +[ccpp-arg-table] + name = ty_rad_sw + type = ddt +[ sfc_up_sw ] + standard_name = surface_upwelling_shortwave_radiation_flux + units = W m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys +[ sfc_down_sw ] + standard_name = surface_downwelling_shortwave_radiation_flux + units = W m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys diff --git a/test/nested_suite_test/rad_lw.F90 b/test/nested_suite_test/rad_lw.F90 new file mode 100644 index 00000000..5859f8bf --- /dev/null +++ b/test/nested_suite_test/rad_lw.F90 @@ -0,0 +1,35 @@ +module rad_lw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw + + implicit none + private + + public :: rad_lw_run + +contains + + !> \section arg_table_rad_lw_run Argument Table + !! \htmlinclude arg_table_rad_lw_run.html + !! + subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) + + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxLW(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Locals + integer :: icol + + errmsg = '' + errflg = 0 + + do icol=1,ncol + fluxLW(icol)%sfc_up_lw = 300._kind_phys + fluxLW(icol)%sfc_down_lw = 50._kind_phys + enddo + + end subroutine rad_lw_run + +end module rad_lw diff --git a/test/nested_suite_test/rad_lw.meta b/test/nested_suite_test/rad_lw.meta new file mode 100644 index 00000000..883edf1b --- /dev/null +++ b/test/nested_suite_test/rad_lw.meta @@ -0,0 +1,35 @@ +[ccpp-table-properties] + name = rad_lw + type = scheme + dependencies = module_rad_ddt.F90 +[ccpp-arg-table] + name = rad_lw_run + type = scheme +[ ncol ] + standard_name = horizontal_loop_extent + type = integer + units = count + dimensions = () + intent = in +[fluxLW] + standard_name = longwave_radiation_fluxes + long_name = longwave radiation fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = ty_rad_lw + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/rad_sw.F90 b/test/nested_suite_test/rad_sw.F90 new file mode 100644 index 00000000..ddf35224 --- /dev/null +++ b/test/nested_suite_test/rad_sw.F90 @@ -0,0 +1,35 @@ +module rad_sw + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: rad_sw_run + +contains + + !> \section arg_table_rad_sw_run Argument Table + !! \htmlinclude arg_table_rad_sw_run.html + !! + subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) + + integer, intent(in) :: ncol + real(kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Locals + integer :: icol + + errmsg = '' + errflg = 0 + + do icol=1,ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + enddo + + end subroutine rad_sw_run + +end module rad_sw diff --git a/test/nested_suite_test/rad_sw.meta b/test/nested_suite_test/rad_sw.meta new file mode 100644 index 00000000..d88b9acc --- /dev/null +++ b/test/nested_suite_test/rad_sw.meta @@ -0,0 +1,41 @@ +[ccpp-table-properties] + name = rad_sw + type = scheme +[ccpp-arg-table] + name = rad_sw_run + type = scheme +[ ncol ] + standard_name = horizontal_loop_extent + type = integer + units = count + dimensions = () + intent = in +[ sfc_up_sw ] + standard_name = surface_upwelling_shortwave_radiation_flux + units = W m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ sfc_down_sw ] + standard_name = surface_downwelling_shortwave_radiation_flux + units = W m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=512 + intent = out +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/test/nested_suite_test/radiation2_suite.xml b/test/nested_suite_test/radiation2_suite.xml new file mode 100644 index 00000000..e20b81e8 --- /dev/null +++ b/test/nested_suite_test/radiation2_suite.xml @@ -0,0 +1,10 @@ + + + + + + effrs_calc + + effr_diag + + diff --git a/test/nested_suite_test/radiation3_subsuite.xml b/test/nested_suite_test/radiation3_subsuite.xml new file mode 100644 index 00000000..346db62d --- /dev/null +++ b/test/nested_suite_test/radiation3_subsuite.xml @@ -0,0 +1,7 @@ + + + + + rad_sw + + diff --git a/test/nested_suite_test/radiation3_suite.xml b/test/nested_suite_test/radiation3_suite.xml new file mode 100644 index 00000000..89e5bc13 --- /dev/null +++ b/test/nested_suite_test/radiation3_suite.xml @@ -0,0 +1,7 @@ + + + + + + + diff --git a/test/nested_suite_test/radiation4_suite.xml b/test/nested_suite_test/radiation4_suite.xml new file mode 100644 index 00000000..d3df4fb9 --- /dev/null +++ b/test/nested_suite_test/radiation4_suite.xml @@ -0,0 +1,7 @@ + + + + + rad_lw + + diff --git a/test/nested_suite_test/test_host.F90 b/test/nested_suite_test/test_host.F90 new file mode 100644 index 00000000..f3a389e8 --- /dev/null +++ b/test/nested_suite_test/test_host.F90 @@ -0,0 +1,264 @@ +module test_prog + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public test_host + + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 + + !> \section arg_table_suite_info Argument Table + !! \htmlinclude arg_table_suite_info.html + !! + type, public :: suite_info + character(len=cs) :: suite_name = '' + character(len=cs), pointer :: suite_parts(:) => NULL() + character(len=cm), pointer :: suite_input_vars(:) => NULL() + character(len=cm), pointer :: suite_output_vars(:) => NULL() + character(len=cm), pointer :: suite_required_vars(:) => NULL() + end type suite_info + +CONTAINS + + logical function check_suite(test_suite) + use test_host_ccpp_cap, only: ccpp_physics_suite_part_list + use test_host_ccpp_cap, only: ccpp_physics_suite_variables + use test_utils, only: check_list + + ! Dummy argument + type(suite_info), intent(in) :: test_suite + ! Local variables + integer :: sind + logical :: check + integer :: errflg + character(len=512) :: errmsg + character(len=128), allocatable :: test_list(:) + + check_suite = .true. + write(6, *) "Checking suite ", trim(test_suite%suite_name) + ! First, check the suite parts + call ccpp_physics_suite_part_list(test_suite%suite_name, test_list, & + errmsg, errflg) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_parts, 'part names', & + suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check the input variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg, input_vars=.true., output_vars=.false.) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_input_vars, & + 'input variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check the output variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg, input_vars=.false., output_vars=.true.) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_output_vars, & + 'output variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check all required variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_required_vars, & + 'required variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + end function check_suite + + + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) + + use test_host_mod, only: ncols + use test_host_ccpp_cap, only: test_host_ccpp_physics_initialize + use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_initial + use test_host_ccpp_cap, only: test_host_ccpp_physics_run + use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_final + use test_host_ccpp_cap, only: test_host_ccpp_physics_finalize + use test_host_ccpp_cap, only: ccpp_physics_suite_list + use test_host_mod, only: init_data, compare_data + use test_utils, only: check_list + + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval + + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + character(len=512) :: errmsg + integer :: errflg + + ! Initialize our 'data' + call init_data() + + ! Gather and test the inspection routines + num_suites = size(test_suites) + call ccpp_physics_suite_list(suite_names) + retval = check_list(suite_names, test_suites(:)%suite_name, & + 'suite names') + write(6, *) 'Available suites are:' + do index = 1, size(suite_names) + do sind = 1, num_suites + if (trim(test_suites(sind)%suite_name) == & + trim(suite_names(index))) then + exit + end if + end do + write(6, '(i0,3a,i0,a)') index, ') ', trim(suite_names(index)), & + ' = test_suites(', sind, ')' + end do + if (retval) then + do sind = 1, num_suites + check = check_suite(test_suites(sind)) + retval = retval .and. check + end do + end if + !!! Return here if any check failed + if (.not. retval) then + return + end if + + ! Use the suite information to setup the run + do sind = 1, num_suites + call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & + errmsg, errflg) + if (errflg /= 0) then + write(6, '(4a)') 'ERROR in initialize of ', & + trim(test_suites(sind)%suite_name), ': ', trim(errmsg) + end if + end do + + ! Initialize the timestep + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit + end if + if (errflg /= 0) then + exit + end if + end do + + do col_start = 1, ncols, 5 + if (errflg /= 0) then + exit + end if + col_end = MIN(col_start + 4, ncols) + + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + do index = 1, size(test_suites(sind)%suite_parts) + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_run( & + test_suites(sind)%suite_name, & + test_suites(sind)%suite_parts(index), & + col_start, col_end, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(5a)') trim(test_suites(sind)%suite_name), & + '/', trim(test_suites(sind)%suite_parts(index)), & + ': ', trim(errmsg) + exit + end if + end do + end do + end do + + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_timestep_final( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit + end if + end do + + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + trim(errmsg) + write(6,'(2a)') 'An error occurred in ccpp_timestep_final, ', & + 'Exiting...' + exit + end if + end do + + if (errflg == 0) then + ! Run finished without error, check answers + if (compare_data()) then + write(6, *) 'Answers are correct!' + errflg = 0 + else + write(6, *) 'Answers are not correct!' + errflg = -1 + end if + end if + + retval = errflg == 0 + + end subroutine test_host + + end module test_prog diff --git a/test/nested_suite_test/test_host.meta b/test/nested_suite_test/test_host.meta new file mode 100644 index 00000000..da71b182 --- /dev/null +++ b/test/nested_suite_test/test_host.meta @@ -0,0 +1,38 @@ +[ccpp-table-properties] + name = suite_info + type = ddt +[ccpp-arg-table] + name = suite_info + type = ddt + +[ccpp-table-properties] + name = test_host + type = host +[ccpp-arg-table] + name = test_host + type = host +[ col_start ] + standard_name = horizontal_loop_begin + type = integer + units = count + dimensions = () + protected = True +[ col_end ] + standard_name = horizontal_loop_end + type = integer + units = count + dimensions = () + protected = True +[ errmsg ] + standard_name = ccpp_error_message + long_name = Error message for error handling in CCPP + units = None + dimensions = () + type = character + kind = len=512 +[ errflg ] + standard_name = ccpp_error_code + long_name = Error flag for error handling in CCPP + units = 1 + dimensions = () + type = integer diff --git a/test/nested_suite_test/test_host_data.F90 b/test/nested_suite_test/test_host_data.F90 new file mode 100644 index 00000000..c46bbfff --- /dev/null +++ b/test/nested_suite_test/test_host_data.F90 @@ -0,0 +1,102 @@ +module test_host_data + + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw + + implicit none + private + + !> \section arg_table_physics_state Argument Table + !! \htmlinclude arg_table_physics_state.html + type physics_state + real(kind_phys), dimension(:,:), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxLW ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxSW ! Shortwave radiation fluxes + real(kind_phys) :: scalar_varA + real(kind_phys) :: scalar_varB + real(kind_phys) :: tke, tke2 + integer :: scalar_varC + integer :: scheme_order + integer :: num_subcycles + end type physics_state + + public :: physics_state + public :: allocate_physics_state + +contains + + subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) + integer, intent(in) :: cols + integer, intent(in) :: levels + type(physics_state), intent(out) :: state + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice + + if (allocated(state%effrr)) then + deallocate(state%effrr) + end if + allocate(state%effrr(cols, levels)) + + if (allocated(state%effrl)) then + deallocate(state%effrl) + end if + allocate(state%effrl(cols, levels)) + + if (has_ice) then + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + endif + + if (has_graupel) then + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) + + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + endif + + if (has_ice) then + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + endif + + if (allocated(state%fluxLW)) then + deallocate(state%fluxLW) + end if + allocate(state%fluxLW(cols)) + + if (associated(state%fluxSW%sfc_up_sw)) then + nullify(state%fluxSW%sfc_up_sw) + end if + allocate(state%fluxSW%sfc_up_sw(cols)) + + if (associated(state%fluxSW%sfc_down_sw)) then + nullify(state%fluxSW%sfc_down_sw) + end if + allocate(state%fluxSW%sfc_down_sw(cols)) + + ! Initialize scheme counter. + state%scheme_order = 1 + ! Initialize subcycle counter. + state%num_subcycles = 3 + + end subroutine allocate_physics_state + +end module test_host_data diff --git a/test/nested_suite_test/test_host_data.meta b/test/nested_suite_test/test_host_data.meta new file mode 100644 index 00000000..59a0fb4d --- /dev/null +++ b/test/nested_suite_test/test_host_data.meta @@ -0,0 +1,128 @@ +[ccpp-table-properties] + name = physics_state + type = ddt + dependencies = module_rad_ddt.F90 +[ccpp-arg-table] + name = physics_state + type = ddt +[effrr] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in meter + units = m + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys +[effrl] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle + long_name = effective radius of cloud liquid water particle in meter + units = m + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys +[effri] + standard_name = effective_radius_of_stratiform_cloud_ice_particle + long_name = effective radius of cloud ice water particle in meter + units = m + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_indicating_cloud_microphysics_has_ice) +[effrg] + standard_name = effective_radius_of_stratiform_cloud_graupel + long_name = effective radius of cloud graupel in meter + units = m + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + active = (flag_indicating_cloud_microphysics_has_graupel) +[ncg] + standard_name = cloud_graupel_number_concentration + long_name = number concentration of cloud graupel + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + active = (flag_indicating_cloud_microphysics_has_graupel) +[nci] + standard_name = cloud_ice_number_concentration + long_name = number concentration of cloud ice + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + active = (flag_indicating_cloud_microphysics_has_ice) +[scalar_var] + standard_name = scalar_variable_for_testing + long_name = unused scalar variable + units = m + dimensions = () + type = real + kind = kind_phys +[ tke ] + standard_name = turbulent_kinetic_energy + long_name = turbulent_kinetic_energy + units = J kg-1 + dimensions = () + type = real + kind = kind_phys +[ tke2 ] + standard_name = turbulent_kinetic_energy2 + long_name = turbulent_kinetic_energy2 + units = m2 s-2 + dimensions = () + type = real + kind = kind_phys +[fluxSW] + standard_name = shortwave_radiation_fluxes + long_name = shortwave radiation fluxes + units = W m-2 + dimensions = () + type = ty_rad_sw +[fluxLW] + standard_name = longwave_radiation_fluxes + long_name = longwave radiation fluxes + units = W m-2 + dimensions = (horizontal_dimension) + type = ty_rad_lw +[scalar_varA] + standard_name = scalar_variable_for_testing_a + long_name = unused scalar variable A + units = m + dimensions = () + type = real + kind = kind_phys +[scalar_varB] + standard_name = scalar_variable_for_testing_b + long_name = unused scalar variable B + units = m + dimensions = () + type = real + kind = kind_phys +[scalar_varC] + standard_name = scalar_variable_for_testing_c + long_name = unused scalar variable C + units = m + dimensions = () + type = integer +[scheme_order] + standard_name = scheme_order_in_suite + long_name = scheme order in suite definition file + units = None + dimensions = () + type = integer +[num_subcycles] + standard_name = num_subcycles_for_effr + long_name = Number of times to subcycle the effr calculation + units = None + dimensions = () + type = integer + +[ccpp-table-properties] + name = test_host_data + type = module + dependencies = module_rad_ddt.F90 +[ccpp-arg-table] + name = test_host_data + type = module diff --git a/test/nested_suite_test/test_host_mod.F90 b/test/nested_suite_test/test_host_mod.F90 new file mode 100644 index 00000000..09d1fdb5 --- /dev/null +++ b/test/nested_suite_test/test_host_mod.F90 @@ -0,0 +1,126 @@ +module test_host_mod + + use ccpp_kinds, only: kind_phys + use test_host_data, only: physics_state, allocate_physics_state + + implicit none + public + + !> \section arg_table_test_host_mod Argument Table + !! \htmlinclude arg_table_test_host_host.html + !! + integer, parameter :: ncols = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data + +contains + + subroutine init_data() + + ! Allocate and initialize state + call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) + phys_state%effrr = 1.0E-3 ! 1000 microns, in meter + phys_state%effrl = 1.0E-4 ! 100 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_varA = 273.15 ! in K + phys_state%scalar_varB = 1013.0 ! in mb + phys_state%scalar_varC = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter + if (has_graupel) then + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + endif + if (has_ice) then + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + endif + phys_state%tke = 10.0 !J kg-1 + phys_state%tke2 = 42.0 !J kg-1 + + end subroutine init_data + + logical function compare_data() + + real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + + compare_data = .true. + + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected + compare_data = .false. + end if + + if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected + compare_data = .false. + end if + + if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected + compare_data = .false. + end if + + if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected + compare_data = .false. + end if + + end function compare_data + +end module test_host_mod diff --git a/test/nested_suite_test/test_host_mod.meta b/test/nested_suite_test/test_host_mod.meta new file mode 100644 index 00000000..51a2f5c3 --- /dev/null +++ b/test/nested_suite_test/test_host_mod.meta @@ -0,0 +1,42 @@ +[ccpp-table-properties] + name = test_host_mod + type = module +[ccpp-arg-table] + name = test_host_mod + type = module +[ ncols] + standard_name = horizontal_dimension + units = count + type = integer + protected = True + dimensions = () +[ pver ] + standard_name = vertical_layer_dimension + units = count + type = integer + protected = True + dimensions = () +[ phys_state ] + standard_name = physics_state_derived_type + long_name = Physics State DDT + type = physics_state + dimensions = () +[effrs] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + long_name = effective radius of cloud snow particle in meter + units = m + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys +[has_ice] + standard_name = flag_indicating_cloud_microphysics_has_ice + long_name = flag indicating that the cloud microphysics produces ice + units = flag + dimensions = () + type = logical +[has_graupel] + standard_name = flag_indicating_cloud_microphysics_has_graupel + long_name = flag indicating that the cloud microphysics produces graupel + units = flag + dimensions = () + type = logical diff --git a/test/nested_suite_test/test_nested_suite_integration.F90 b/test/nested_suite_test/test_nested_suite_integration.F90 new file mode 100644 index 00000000..09dfea10 --- /dev/null +++ b/test/nested_suite_test/test_nested_suite_integration.F90 @@ -0,0 +1,88 @@ +program test_nested_suite_integration + use test_prog, only: test_host, suite_info, cm, cs + + implicit none + + character(len=cs), target :: test_parts1(3) = (/ & + 'radiation1 ', & + 'rad_lw_group ', & + 'rad_sw_group '/) + + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) + + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) + + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) + + type(suite_info) :: test_suites(1) + logical :: run_okay + + ! Setup expected test suite info + test_suites(1)%suite_name = 'main_suite' + test_suites(1)%suite_parts => test_parts1 + test_suites(1)%suite_input_vars => test_invars1 + test_suites(1)%suite_output_vars => test_outvars1 + test_suites(1)%suite_required_vars => test_reqvars1 + + call test_host(run_okay, test_suites) + + if (run_okay) then + STOP 0 + else + STOP -1 + end if +end program test_nested_suite_integration