diff --git a/.circleci/config.yml b/.circleci/config.yml index b80539e281f7..bae974ba32af 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -17,7 +17,7 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 baselibs_version: &baselibs_version v7.23.0 -bcs_version: &bcs_version v11.3.0 +bcs_version: &bcs_version v11.5.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: @@ -33,7 +33,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran,ifort] + compiler: [gfortran, ifort] cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL @@ -49,7 +49,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [ifort] + compiler: [gfortran, ifort] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false @@ -57,7 +57,8 @@ workflows: remove_pflogger: true extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_WITH_FARGPARSE=OFF -DUSE_EXTDATA2G=OFF -DBUILD_SHARED_MAPL=OFF" run_unit_tests: true - ctest_options: "-L 'ESSENTIAL' --output-on-failure" + # ExtData1G tests were removed from ESSENTIAL, so we run them separately here as UFS might still use 1G? + ctest_options: "-L 'ESSENTIAL|EXTDATA1G_SMALL_TESTS' --output-on-failure" # Run MAPL Tutorials - ci/run_mapl_tutorial: @@ -161,7 +162,6 @@ workflows: checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 - extra_cmake_options: "-DBUILD_WITH_FLAP=ON" build-and-publish-docker: when: @@ -196,8 +196,8 @@ workflows: baselibs_version: *baselibs_version container_name: mapl mpi_name: openmpi - mpi_version: 5.0.0 + mpi_version: 5.0.2 compiler_name: gcc - compiler_version: 12.1.0 + compiler_version: 13.2.0 image_name: geos-env-mkl tag_build_arg_name: *tag_build_arg_name diff --git a/.github/actions/deploy-ford-docs/action.yml b/.github/actions/deploy-ford-docs/action.yml index 9d69fbe2a0a5..94dee1da508a 100644 --- a/.github/actions/deploy-ford-docs/action.yml +++ b/.github/actions/deploy-ford-docs/action.yml @@ -61,12 +61,14 @@ runs: shell: bash - name: Build Documentation - run: ford ${{ inputs.ford-input }} + run: | + cd docs/Ford + ford ${{ inputs.ford-input }} shell: bash - name: Deploy Pages uses: JamesIves/github-pages-deploy-action@v4 - if: github.event_name == 'push' && github.repository == 'GEOS-ESM/MAPL' && ( startsWith( github.ref, 'refs/tags/v' ) || github.ref == 'refs/heads/main' ) + if: github.event_name == 'push' && github.repository == 'GEOS-ESM/MAPL' && ( startsWith( github.ref, 'refs/tags/v' ) || github.ref == 'refs/heads/main' || github.ref == 'refs/heads/release/MAPL-v3' ) with: folder: ${{ inputs.doc-folder }} token: ${{ inputs.token }} diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index bb73ea670da0..3e4740e794dc 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -21,7 +21,11 @@ jobs: - name: Build and Deploy Docs uses: ./.github/actions/deploy-ford-docs with: - ford-input: docs/Ford/docs-with-remote-esmf.md + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: docs-with-remote-esmf.md doc-folder: docs/Ford/doc token: ${{ secrets.GITHUB_TOKEN }} @@ -34,7 +38,11 @@ jobs: - name: Build and Deploy Dev Docs uses: ./.github/actions/deploy-ford-docs with: - ford-input: docs/Ford/docs-with-remote-esmf.public_private_protected.md + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: docs-with-remote-esmf.public_private_protected.md doc-folder: docs/Ford/dev-doc token: ${{ secrets.GITHUB_TOKEN }} target-folder: dev-doc diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index e8634bab8aa8..f4b1e5f07cbc 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -13,11 +13,29 @@ on: - ".editorconfig" jobs: + check-ford-docs: + name: Build Ford Docs + runs-on: ubuntu-latest + steps: + - name: Checkout + uses: actions/checkout@v4 + + - name: Build and Deploy Docs + uses: ./.github/actions/deploy-ford-docs + with: + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: ford-ci.md + doc-folder: docs/Ford/ci-doc + token: ${{ secrets.GITHUB_TOKEN }} + build_test_mapl: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.23.0-openmpi_5.0.0-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.24.0-openmpi_5.0.2-gcc_13.2.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -68,7 +86,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.23.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.24.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/.gitignore b/.gitignore index 5e844f143a4a..f58506891921 100644 --- a/.gitignore +++ b/.gitignore @@ -10,8 +10,13 @@ CMakeUserPresets.json # Ignore possible symlinked build and install directories -build-* -install-* +# Note: we can't use a / at the end because they might be +# symlink to a directory +build* +install* + +# If you build with spack libraries, you can get spack log files +spack*.log *.swp *.swo diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py index 7e1c36c154af..13d113da3787 100755 --- a/Apps/MAPL_GridCompSpecs_ACG.py +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -9,32 +9,26 @@ from enum import Enum +################################# CONSTANTS #################################### SUCCESS = 0 - CATEGORIES = ("IMPORT","EXPORT","INTERNAL") +LONGNAME_GLOB_PREFIX = "longname_glob_prefix" +# constants for logicals +TRUE_VALUE = '.true.' +FALSE_VALUE = '.false.' +TRUE_VALUES = {'t', 'true', 'yes', 'y', 'si', 'oui', 'sim'} +FALSE_VALUES = {'f', 'false', 'no', 'n', 'no', 'non', 'nao'} -"""Helper functions -lambda (anonymous) functions are simple functions (usually one line), -of the form: - lambda x, y, z, ...: -where 'x, y, z, ...' represents one or more arguments (It's a tuple.) -They are quite handy for processing sequences (think: list, tuples, sets) -They are used here for emitting values, as well. -""" - -# Return the value -identity_emit = lambda value: value -# Return value in quotes -string_emit = lambda value: ("'" + value + "'") if value else None -# Return value in brackets -array_emit = lambda value: ('[' + value + ']') if value else None -lstripped = lambda s: s.lower().strip(' .') +# constants used for Option.DIMS and computing rank +DIMS_OPTIONS = [('MAPL_DimsVertOnly', 1, 'z'), ('MAPL_DimsHorzOnly', 2, 'xy'), ('MAPL_DimsHorzVert', 3, 'xyz')] +RANKS = dict([(entry, rank) for entry, rank, _ in DIMS_OPTIONS]) -# emit function for character arrays -string_array_emit = lambda value: make_string_array(value) if value else None +############################### HELPER FUNCTIONS ############################### def make_string_array(s): """ Returns a string representing a Fortran character array """ + rm_quotes = lambda s: s.strip().strip('"\'').strip() + add_quotes = lambda s: "'" + s + "'" ss = s.strip() if ',' in ss: ls = [s.strip() for s in s.strip().split(',')] @@ -46,38 +40,106 @@ def make_string_array(s): ss = ','.join([add_quotes(s) for s in ls]) return f"[character(len={n}) :: {ss}]" -rm_quotes = lambda s: s.strip().strip('"\'').strip() -add_quotes = lambda s: "'" + s + "'" - -mangle_name = lambda name: string_emit(name.replace("*","'//trim(comp_name)//'")) if name else None -make_internal_name = lambda name: name.replace('*','') if name else None - def make_entry_emit(dictionary): """ Returns a emit function that looks up the value in dictionary """ return lambda key: dictionary[key] if key in dictionary else None -# constants used for Option.DIMS -DIMS_OPTIONS = [('MAPL_DimsVertOnly', 1, 'z'), ('MAPL_DimsHorzOnly', 2, 'xy'), ('MAPL_DimsHorzVert', 3, 'xyz')] -DIMS_EMIT = make_entry_emit(dict([(alias, entry) for entry, _, alias in DIMS_OPTIONS])) -RANKS = dict([(entry, rank) for entry, rank, _ in DIMS_OPTIONS]) +def mangle_name_prefix(name, parameters = None): + pre = 'comp_name' + if isinstance(parameters, tuple): + pre = parameters[0] if parameters[0] else pre + codestring = f"'//trim({pre})//'" + return string_emit(name.replace("*",codestring)) if name else None + +def get_fortran_logical(value_in): + """ Return string representing Fortran logical from an input string """ + """ representing a logical value input """ + + try: + if value_in is None: + raise ValueError("'None' is not valid for get_fortran_logical.") + if value_in.strip().lower() in TRUE_VALUES: + val_out = TRUE_VALUE + elif value_in.strip().lower() in FALSE_VALUES: + val_out = FALSE_VALUE + else: + raise ValueError("Unrecognized logical: " + value_in) + except Exception: + raise + + return val_out + +def compute_rank(dims, ungridded): + extra_rank = len(ungridded.strip('][').split(',')) if ungridded else 0 + return RANKS[dims] + extra_rank + +def header(): + """ + Returns a standard warning that can be placed at the top of each + generated _Fortran_ include file. + """ + + return """ +! ------------------- +! W A R N I N G +! ------------------- +! +! This code fragment is automatically generated by MAPL_GridCompSpecs_ACG. +! Please DO NOT edit it. Any modification made in here will be overwritten +! next time this file is auto-generated. Instead, enter your additions +! or deletions in the .rc file in the src tree. +! + """ + +def open_with_header(filename): + f = open(filename,'w') + f.write(header()) + return f + +# callable object (function) +class ParameterizedEmitFunction: + + def __init__(self, emit, *parameter_keys): + self.emit = emit + self.parameter_keys = parameter_keys + + def __call__(self, name, parameters): + parameter_values = tuple(parameters.get(key) for key in self.parameter_keys) + return self.emit(name, parameter_values) + +##################### EMIT functions for writing AddSpecs ###################### +# Return the value +identity_emit = lambda value: value +# Return value in quotes +string_emit = lambda value: ("'" + value + "'") if value else None +# Return value in brackets +array_emit = lambda value: ('[' + value + ']') if value else None +# Strip '.' and ' ' [SPACE] +lstripped = lambda s: s.lower().strip(' .') +# emit function for character arrays +string_array_emit = lambda value: make_string_array(value) if value else None +# mangle name for SHORT_NAME +mangle_name = lambda name: string_emit(name.replace("*","'//trim(comp_name)//'")) if name else None +# mangle name for internal use +make_internal_name = lambda name: name.replace('*','') if name else None +# emit function for LONG_NAME +mangle_longname = ParameterizedEmitFunction(mangle_name_prefix, LONGNAME_GLOB_PREFIX) +# emit for function for DIMS +DIMS_EMIT = make_entry_emit(dict([(alias, entry) for entry, _, alias in DIMS_OPTIONS])) # emit function for Option.VLOCATION VLOCATION_EMIT = make_entry_emit({'C': 'MAPL_VlocationCenter', 'E': 'MAPL_VlocationEdge', 'N': 'MAPL_VlocationNone'}) - +# emit function for Option.ADD2EXPORT +ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) +# emit function for logical-valued options +logical_emit = lambda s: TRUE_VALUE if lstripped(s) in TRUE_VALUES else FALSE_VALUE if lstripped(s) in FALSE_VALUES else None # emit function for Option.RESTART RESTART_EMIT = make_entry_emit({'OPT' : 'MAPL_RestartOptional', 'SKIP' : 'MAPL_RestartSkip', 'REQ' : 'MAPL_RestartRequired', 'BOOT' : 'MAPL_RestartBoot', 'SKIPI': 'MAPL_RestartSkipInitial'}) -# emit function for logical-valued options -TRUEVALUES = {'t', 'true', 'yes', 'y', 'si', 'oui', 'sim'} -FALSEVALUES = {'f', 'false', 'no', 'n', 'no', 'non', 'nao'} -TRUE_VALUE = '.true.' -FALSE_VALUE = '.false.' -logical_emit = lambda s: TRUE_VALUE if lstripped(s) in TRUEVALUES else FALSE_VALUE if lstripped(s) in FALSEVALUES else None -# emit function for Option.ADD2EXPORT -ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) +################################### OPTIONS #################################### # parent class for class Option # defines a few methods class OptionType(Enum): @@ -101,8 +163,8 @@ def get_mandatory_options(cls): 'SHORT_NAME': ('short_name', mangle_name, True), 'NAME': ('short_name', mangle_name, True), 'DIMS': ('dims', DIMS_EMIT, True), - 'LONG_NAME': ('long_name', mangle_name, True), - 'LONG NAME': ('long_name', mangle_name, True), + 'LONG_NAME': ('long_name', mangle_longname, True), + 'LONG NAME': ('long_name', mangle_longname, True), 'UNITS': ('units', string_emit, True), # OPTIONAL 'ADD2EXPORT': ('add2export', ADD2EXPORT_EMIT), @@ -146,6 +208,9 @@ def get_mandatory_options(cls): 'RANK': ('rank', None, False, False) }, type = OptionType) + +###################### RULES to test conditions on Options ##################### +# relations for rules on Options def relation(relop, lhs, rhs, values): """ Returns the result of the relop relation of lhs and rhs using values for lookups """ l = values[lhs] if isinstance(lhs, Option) else lhs @@ -203,6 +268,7 @@ def check(self, values): """ run rules on Option values """ return self.rule(values) +# These are the CURRENT RULES of Option (column) values def check_option_values(values): rules = [Rule(conditions = [(Option.DIMS, equals, 'MAPL_DimsHorzVert', 'is equal to MAPL_DimsHorzVert'), @@ -213,51 +279,9 @@ def check_option_values(values): for rule in rules: rule.check(values) -def compute_rank(dims, ungridded): - extra_rank = len(ungridded.strip('][').split(',')) if ungridded else 0 - return RANKS[dims] + extra_rank - -def digest(specs): - """ Set Option values from parsed specs """ - mandatory_options = Option.get_mandatory_options() - digested_specs = dict() - - for category in specs: - category_specs = list() # All the specs for the category - for spec in specs[category]: # spec from list - dims = None - ungridded = None - option_values = dict() # dict of option values - for column in spec: # for spec emit value - column_value = spec[column] - option = Option[column.upper()] # use column name to find Option - option_value = option(column_value) # emit value - option_values[option] = option_value # add value to dict - if option == Option.SHORT_NAME: - option_values[Option.MANGLED_NAME] = Option.MANGLED_NAME(column_value) - option_values[Option.INTERNAL_NAME] = Option.INTERNAL_NAME(column_value) - elif option == Option.DIMS: - dims = option_value - elif option == Option.UNGRIDDED: - ungridded = option_value -# MANDATORY - for option in mandatory_options: - if option not in option_values: - raise RuntimeError(option.name + " is missing from spec.") -# END MANDATORY - option_values[Option.RANK] = compute_rank(dims, ungridded) -# CHECKS HERE - try: - check_option_values(option_values) - except Exception: - raise -# END CHECKS - category_specs.append(option_values) - digested_specs[category] = category_specs - return digested_specs - ############################################################### +# MAPL_DATASPEC class class MAPL_DataSpec: """Declare and manipulate an import/export/internal specs for a MAPL Gridded component""" @@ -353,6 +377,36 @@ def emit_trailer(self, nullify=False): text = self.newline() return text + +############################ PARSE COMMAND ARGUMENTS ########################### +def get_args(): + parser = argparse.ArgumentParser(description='Generate import/export/internal specs for MAPL Gridded Component') + parser.add_argument("input", action='store', + help="input filename") + parser.add_argument("-n", "--name", action="store", + help="override default grid component name derived from input filename") + parser.add_argument("-i", "--import_specs", action="store", nargs='?', + default=None, const="{component}_Import___.h", + help="override default output filename for AddImportSpec() code") + parser.add_argument("-x", "--export_specs", action="store", nargs='?', + default=None, const="{component}_Export___.h", + help="override default output filename for AddExternalSpec() code") + parser.add_argument("-p", "--internal_specs", action="store", nargs='?', + default=None, const="{component}_Internal___.h", + help="override default output filename for AddImportSpec() code") + parser.add_argument("-g", "--get-pointers", action="store", nargs='?', + default=None, const="{component}_GetPointer___.h", + help="override default output filename for get_pointer() code") + parser.add_argument("-d", "--declare-pointers", action="store", nargs='?', + const="{component}_DeclarePointer___.h", default=None, + help="override default output filename for pointer declaration code") + parser.add_argument("--" + LONGNAME_GLOB_PREFIX, dest=LONGNAME_GLOB_PREFIX, + action="store", nargs='?', default=None, + help="alternative prefix for long_name substitution") + return parser.parse_args() + + +# READ_SPECS function def read_specs(specs_filename): """Returns dict of (category: list of dict of (option name: option value) """ def csv_record_reader(csv_reader): @@ -396,88 +450,56 @@ def dataframe(reader, columns): return specs -def get_fortran_logical(value_in): - """ Return string representing Fortran logical from an input string """ - """ representing a logical value input """ - TRUE_VALUE = '.true.' - FALSE_VALUE = '.false.' - TRUE_VALUES = {TRUE_VALUE, 't', 'true', '.t.', 'yes', 'y', 'si', 'oui', 'sim'} - FALSE_VALUES = {FALSE_VALUE, 'f', 'false', '.f.', 'no', 'n', 'no', 'non', 'nao'} - - try: - if value_in is None: - raise ValueError("'None' is not valid for get_fortran_logical.") - if value_in.strip().lower() in TRUE_VALUES: - val_out = TRUE_VALUE - elif value_in.strip().lower() in FALSE_VALUES: - val_out = FALSE_VALUE - else: - raise ValueError("Unrecognized logical: " + value_in) - except Exception: - raise - - return val_out -def header(): - """ - Returns a standard warning that can be placed at the top of each - generated _Fortran_ include file. - """ - - return """ -! ------------------- -! W A R N I N G -! ------------------- -! -! This code fragment is automatically generated by MAPL_GridCompSpecs_ACG. -! Please DO NOT edit it. Any modification made in here will be overwritten -! next time this file is auto-generated. Instead, enter your additions -! or deletions in the .rc file in the src tree. -! - """ - -def open_with_header(filename): - f = open(filename,'w') - f.write(header()) - return f - -############################################# -# Main program begins here -############################################# - -if __name__ == "__main__": +# DIGEST +def digest(specs, args): + """ Set Option values from parsed specs """ + arg_dict = vars(args) + mandatory_options = Option.get_mandatory_options() + digested_specs = dict() -# Process command line arguments - parser = argparse.ArgumentParser(description='Generate import/export/internal specs for MAPL Gridded Component') - parser.add_argument("input", action='store', - help="input filename") - parser.add_argument("-n", "--name", action="store", - help="override default grid component name derived from input filename") - parser.add_argument("-i", "--import_specs", action="store", nargs='?', - default=None, const="{component}_Import___.h", - help="override default output filename for AddImportSpec() code") - parser.add_argument("-x", "--export_specs", action="store", nargs='?', - default=None, const="{component}_Export___.h", - help="override default output filename for AddExternalSpec() code") - parser.add_argument("-p", "--internal_specs", action="store", nargs='?', - default=None, const="{component}_Internal___.h", - help="override default output filename for AddImportSpec() code") - parser.add_argument("-g", "--get-pointers", action="store", nargs='?', - default=None, const="{component}_GetPointer___.h", - help="override default output filename for get_pointer() code") - parser.add_argument("-d", "--declare-pointers", action="store", nargs='?', - const="{component}_DeclarePointer___.h", default=None, - help="override default output filename for pointer declaration code") - args = parser.parse_args() + for category in specs: + category_specs = list() # All the specs for the category + for spec in specs[category]: # spec from list + dims = None + ungridded = None + option_values = dict() # dict of option values + for column in spec: # for spec emit value + column_value = spec[column] + option = Option[column.upper()] # use column name to find Option + # emit value + if type(option.emit) is ParameterizedEmitFunction: + option_value = option.emit(column_value, arg_dict) + else: + option_value = option.emit(column_value) + option_values[option] = option_value # add value to dict + if option == Option.SHORT_NAME: + option_values[Option.MANGLED_NAME] = Option.MANGLED_NAME(column_value) + option_values[Option.INTERNAL_NAME] = Option.INTERNAL_NAME(column_value) + elif option == Option.DIMS: + dims = option_value + elif option == Option.UNGRIDDED: + ungridded = option_value +# MANDATORY + for option in mandatory_options: + if option not in option_values: + raise RuntimeError(option.name + " is missing from spec.") +# END MANDATORY + option_values[Option.RANK] = compute_rank(dims, ungridded) +# CHECKS HERE + try: + check_option_values(option_values) + except Exception: + raise +# END CHECKS + category_specs.append(option_values) + digested_specs[category] = category_specs -# Process blocked CSV input file - parsed_specs = read_specs(args.input) + return digested_specs + -# Emit values - try: - specs = digest(parsed_specs) - except Exception: - raise +################################# EMIT_VALUES ################################## +def emit_values(specs, args): if args.name: component = args.name @@ -526,5 +548,27 @@ def open_with_header(filename): if f_get_pointers: f_get_pointers.close() - sys.exit(SUCCESS) +############################################# +# MAIN program begins here +############################################# + +if __name__ == "__main__": +# Process command line arguments + args = get_args() + +# Process blocked CSV input file + parsed_specs = read_specs(args.input) + +# Digest specs from file to output structure + try: + specs = digest(parsed_specs, args) + + except Exception: + raise + +# Emit values + emit_values(specs, args) + +# FIN + sys.exit(SUCCESS) diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index 5abbcaddfc16..8b4810c4d073 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -26,6 +26,7 @@ module regrid_util_support_mod integer :: deflate, shave integer :: quantize_algorithm integer :: quantize_level + logical :: use_weights contains procedure :: create_grid procedure :: process_command_line @@ -97,6 +98,7 @@ subroutine process_command_line(this,rc) this%deflate=0 this%quantize_algorithm=1 this%quantize_level=0 + this%use_weights = .false. nargs = command_argument_count() do i=1,nargs call get_command_argument(i,str) @@ -159,6 +161,8 @@ subroutine process_command_line(this,rc) case('-quantize_level') call get_command_argument(i+1,astr) read(astr,*)this%quantize_level + case('-file_weights') + this%use_weights = .true. case('--help') if (mapl_am_I_root()) then @@ -413,9 +417,9 @@ subroutine main() if (mapl_am_i_root()) write(*,*)'processing timestep from '//trim(filename) time = tSeries(i) if (support%onlyvars) then - call MAPL_Read_bundle(bundle,trim(filename),time=time,regrid_method=support%regridMethod,only_vars=support%vars,_RC) + call MAPL_Read_bundle(bundle,trim(filename),time=time,regrid_method=support%regridMethod,only_vars=support%vars,file_weights=support%use_weights, _RC) else - call MAPL_Read_bundle(bundle,trim(filename),time=time,regrid_method=support%regridMethod,_RC) + call MAPL_Read_bundle(bundle,trim(filename),time=time,regrid_method=support%regridMethod,file_weights=support%use_weights, _RC) end if call t_prof%stop("Read") diff --git a/CHANGELOG.md b/CHANGELOG.md index f4aadf01d7d9..b49acffbec99 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,91 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +### Changed + +### Fixed + +### Removed + +### Deprecated + +## [2.47.1] - 2024-07-17 + +### Fixed + +- Fixed bug in FieldSet routines when passing R8 ESMF fields + +## [2.47.0] - 2024-06-24 + +### Added + +- Add new option to `Regrid_Util.x` to write and re-use ESMF pregenerated weights +- If file path length exceeds `ESMF_MAXSTR`, add `_FAIL` in subroutine fglob +- Add GNU UFS-like CI test +- Add capability to mangle `LONG_NAME` in ACG with a different prefix + +### Changed + +- pFIO Clients don't send "Done" message when there is no request +- Update `components.yaml` + - ESMA_cmake v3.46.0 + - Fix bugs in meson detection + - Fix for building on older macOS + - Add `esma_add_fortran_submodules` function +- Updated `checkpoint_simulator` to not create and close file if not writing +- Update ExtData tests + - Add new category of `SLOW` tests that take 10-30 seconds and remove them from the `ESSENTIAL` + label run in CI + - Remove ExtData1G tests from `ESSENTIAL` label, but run them in the UFS-like CI test +- Improved timing for station sampler with GHCNd input: used LocStream with CS background, LS with uniform distributed points, and `MPI_GatherV` + +### Fixed + +- Fixed a bug in `generate_newnxy` in `MAPL_SwathGridFactory.F90` (`NX*NY=Ncore`) +- Fixes for NVHPC 24.5 + - Convert `MAPL_GeosatMaskMod` to "interface-in-both-files" submodule style + +## [2.46.2] - 2024-05-31 + +### Removed + +- Remove excessive print statements in `generic/OpenMP_Support.F90` + +## [2.46.1] - 2024-05-10 + +## Fixed + +- Update `components.yaml` to avoid f2py error with python 3.11 + - ESMA_cmake v3.45.1 + - Fix bug in meson detection + +## [2.46.0] - 2024-05-02 + +### Added + +- Update `FindESMF.cmake` to match that in ESMF 8.6.1 +- Add timer to the sampler code +- Set required version of ESMF to 8.6.1 +- Update `components.yaml` + - ESMA_cmake v3.45.0 + - `BUILT_ON_SLES15` set to `FALSE` on NCCS if not built on SLES15 + - Update `FindESMF.cmake` to match that in ESMF 8.6.1 + - Suppress remarks in Intel Fortran Classic 2021.12 + - ESMA_env v4.29.0 (Baselibs 7.24.0) + - Update to ESMF 8.6.1b04 + - NCO 5.2.4 + - curl 8.7.1 + +### Fixed + +- Fixed non-Baselibs build using `ESMF::ESMF` target + +## [2.45.0] - 2024-04-25 + +### Added + +- Add glob function in sampler code, supporting wild character, e.g., filename template = `amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4` +- Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Replace local HorzIJIndex sear with the GlobalHorzIJindex search - Change grd_is_ok function to avoid collective call - Allow fields with ungridded dimension and bundles to be created in ExtDataDriver.x @@ -32,9 +117,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Implemented a new algorthm to read tile files - Added two options, depends_on and depends_on_children, to ACG - Added memory diagnostics for ExtData2G +- Add CI job to test Ford build (does not publish) ### Changed +- Release the pfio memory as early as possible - Trajectory sampler: ls_rt -> ls_chunk (via mpi_gatherV) -> ls_distributed(bk=cs_grid; via ESMF_FieldRedistStore), aiming to save computational time. To gather 3D data via mpi, options for level by level and single-3D are added via ifdef. - The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata @@ -51,9 +138,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Updates to GFE v1.15 - Fixes for NAG - Use GCC 11.4 as Intel backing compiler at NCCS SLES15 +- Update CI to use Baselibs 7.23.0 and GCC 13.2 for GNU tests ### Fixed +- Change to IntArray's pointer to store data to avoid Intel Ifort bug - Fix inconsistency in History output so that multi-dimensional coordinate variables are also compressed if requested in the collection - Minor workaround to enable NAG 7.2.01 to compile. (Reproducer submitted to NAG.) - Fixed bug with split restart files @@ -62,7 +151,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed -### Deprecated +- Removed CMake logic for macOS + Intel as that is an unsupported configuration ## [2.44.3] - 2024-03-28 diff --git a/CMakeLists.txt b/CMakeLists.txt index 96875bfee68a..34a9c4d35e30 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.44.3 + VERSION 2.47.1 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui @@ -58,7 +58,8 @@ if (NOT COMMAND esma) endif () -list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") +# This tells cmake to assume MAPL's cmake directory is the first place to look +list (PREPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") option (BUILD_SHARED_MAPL "Build shared MAPL libraries" ON) if (BUILD_SHARED_MAPL) @@ -148,21 +149,8 @@ if (NOT Baselibs_FOUND) endif() if (NOT TARGET ESMF::ESMF) - find_package(ESMF 8.6.0 MODULE REQUIRED) - - # ESMF as used in MAPL requires MPI - # NOTE: This looks odd because some versions of FindESMF.cmake out in the - # world provide an "esmf" target while others provide "ESMF". So we - # need this ugliness to support both. - if (TARGET ESMF::ESMF) - target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) - else() - target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) - # MAPL and GEOS use lowercase target due to historical reasons but - # the latest FindESMF.cmake file from ESMF produces an ESMF target. - add_library(ESMF::ESMF ALIAS ESMF) - add_library(ESMF::ESMF ALIAS esmf) - endif() + find_package(ESMF 8.6.1 MODULE REQUIRED) + target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) endif () else () # This is an ESMF version test when using Baselibs which doesn't use the diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index 01ccb4b5e8c2..16d5f4b931c3 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -27,25 +27,10 @@ set (EOS ) set (lib MAPL_cfio_${precision}) -if (APPLE AND CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 20.2.1) - set (LIBRARY_TYPE STATIC) - ecbuild_warn ( - "Found Intel oneAPI on macOS.\n" - "MAPL developers have found an issue with Intel oneAPI on macOS\n" - "where GEOSgcm.x would not work. Debugging found the issue was\n" - "that command_argument_count() would return -1 which should *NEVER*\n" - "happen per Fortran Standard and then this broke FLAP.\n" - "A workaround was found that if the ${this} library was compiled\n" - "as TYPE STATIC, the model would work. So we are setting ${this} as\n" - "a TYPE STATIC library. Note: This might interfere with coupled model.") -else () - set (LIBRARY_TYPE ${MAPL_LIBRARY_TYPE}) -endif () - esma_add_library (${lib} SRCS ${srcs} DEPENDENCIES ESMF::ESMF NetCDF::NetCDF_Fortran - TYPE ${LIBRARY_TYPE} + TYPE ${MAPL_LIBRARY_TYPE} ) if (precision MATCHES "r8") diff --git a/Tests/ExtData_Testing_Framework/CMakeLists.txt b/Tests/ExtData_Testing_Framework/CMakeLists.txt index db2f9f97937c..507ff970b7fe 100644 --- a/Tests/ExtData_Testing_Framework/CMakeLists.txt +++ b/Tests/ExtData_Testing_Framework/CMakeLists.txt @@ -2,37 +2,50 @@ string(REPLACE " " ";" MPI_Fortran_LIBRARY_VERSION_LIST ${MPI_Fortran_LIBRARY_VERSION_STRING}) list(GET MPI_Fortran_LIBRARY_VERSION_LIST 0 MPI_Fortran_LIBRARY_VERSION_FIRSTWORD) if(MPI_Fortran_LIBRARY_VERSION_FIRSTWORD MATCHES "Open") - list(APPEND MPIEXEC_PREFLAGS "-oversubscribe") + list(APPEND MPIEXEC_PREFLAGS "-oversubscribe") endif() file(STRINGS "test_cases/extdata_1g_cases.txt" TEST_CASES_1G) set(cutoff "7") +# We want to make a list of tests that are slow and can +# be skipped for ESSENTIAL testing. Most ExtData tests +# take 1-2 seconds at most, but some take 20-30 seconds. +set(SLOW_TESTS + "case6" + "case14" + "case15" + "case16" + "case20" + "case22" + "case23" +) + foreach(TEST_CASE ${TEST_CASES_1G}) if (EXISTS ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc) - file(READ ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc num_procs) + file(READ ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc num_procs) else() - set(num_procs "1") + set(num_procs "1") endif() add_test( - NAME "ExtData1G_${TEST_CASE}" - COMMAND ${CMAKE_COMMAND} - -DTEST_CASE=${TEST_CASE} - -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} - -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} - -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin - -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} - -DIS_EXTDATA2G=NO - -P ${CMAKE_CURRENT_SOURCE_DIR}/run_extdata.cmake - ) - if (${num_procs} LESS ${cutoff}) - set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_SMALL_TESTS") - set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "ESSENTIAL") + NAME "ExtData1G_${TEST_CASE}" + COMMAND ${CMAKE_COMMAND} + -DTEST_CASE=${TEST_CASE} + -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} + -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} + -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin + -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} + -DIS_EXTDATA2G=NO + -P ${CMAKE_CURRENT_SOURCE_DIR}/run_extdata.cmake + ) + if (${num_procs} GREATER ${cutoff}) + set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_BIG_TESTS") + elseif (${TEST_CASE} IN_LIST SLOW_TESTS) + set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_SLOW_TESTS") else() - set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_BIG_TESTS") + set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_SMALL_TESTS") endif() - endforeach() file(STRINGS "test_cases/extdata_2g_cases.txt" TEST_CASES_2G) @@ -40,25 +53,27 @@ file(STRINGS "test_cases/extdata_2g_cases.txt" TEST_CASES_2G) foreach(TEST_CASE ${TEST_CASES_2G}) if (EXISTS ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc) - file(READ ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc num_procs) + file(READ ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc num_procs) else() - set(num_procs "1") + set(num_procs "1") endif() add_test( - NAME "ExtData2G_${TEST_CASE}" - COMMAND ${CMAKE_COMMAND} - -DTEST_CASE=${TEST_CASE} - -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} - -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} - -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin - -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} - -DIS_EXTDATA2G=YES - -P ${CMAKE_CURRENT_SOURCE_DIR}/run_extdata.cmake - ) - if (${num_procs} LESS ${cutoff}) - set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_SMALL_TESTS") - set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "ESSENTIAL") + NAME "ExtData2G_${TEST_CASE}" + COMMAND ${CMAKE_COMMAND} + -DTEST_CASE=${TEST_CASE} + -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} + -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} + -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin + -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} + -DIS_EXTDATA2G=YES + -P ${CMAKE_CURRENT_SOURCE_DIR}/run_extdata.cmake + ) + if (${num_procs} GREATER ${cutoff}) + set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_BIG_TESTS") + elseif (${TEST_CASE} IN_LIST SLOW_TESTS) + set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_SLOW_TESTS") else() - set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_BIG_TESTS") + set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_SMALL_TESTS") + set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "ESSENTIAL") endif() endforeach() diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 30b018eeba43..20b27e36deea 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2900,6 +2900,7 @@ function grid_is_ok(grid) result(OK) print*, "Error: It could be " print*, " 1)Grid is NOT gnomonic_ed;" print*, " 2)lats lons from MAPL_GridGetCorners are NOT accurate (single precision from ESMF)" + print*, " 3)This is a stretched grid which is not yet supported" OK = .false. return endif diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 02aa55f6af08..8f8945af4771 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -47,7 +47,7 @@ set (srcs ESMF_CFIOPtrVectorMod.F90 CFIOCollection.F90 MAPL_CFIO.F90 regex_module.F90 StringTemplate.F90 MAPL_SphericalGeometry.F90 - regex_F.c + regex_F.c MAPL_ObsUtil.c c_mapl_locstream_F.c getrss.c memuse.c Base/Base_Base.F90 Base/Base_Base_implementation.F90 TimeStringConversion.F90 diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 17e41d718d71..1b96fad92ae8 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -10,6 +10,7 @@ module MAPL_ObsUtilMod use pFIO_FileMetadataMod, only : FileMetadata use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + use, intrinsic :: iso_c_binding implicit none integer, parameter :: mx_ngeoval = 60 ! GRS80 by Moritz @@ -59,6 +60,18 @@ module MAPL_ObsUtilMod module procedure sort_four_arrays_by_time end interface sort_multi_arrays_by_time + interface + function f_call_c_glob(search_name, filename, slen) & + & result(stat) bind(C, name="glob_C") + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + character (kind=c_char), intent(in) :: search_name(*) + character (kind=c_char), intent(out) :: filename(*) + integer, intent(inout) :: slen + end function f_call_c_glob + end interface + contains subroutine get_obsfile_Tbracket_from_epoch(currTime, & @@ -546,13 +559,9 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_TimeInterval) :: dT type(ESMF_Time) :: time integer :: i, j, u - - character(len=ESMF_MAXSTR) :: file_template_left - character(len=ESMF_MAXSTR) :: file_template_right - character(len=ESMF_MAXSTR) :: filename_left - character(len=ESMF_MAXSTR) :: filename_full + logical :: allow_wild_char character(len=ESMF_MAXSTR) :: filename2 - character(len=ESMF_MAXSTR) :: cmd + call ESMF_TimeIntervalGet(obsfile_interval, s_r8=dT0_s, rc=status) s = dT0_s * f_index @@ -565,9 +574,20 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! parse time info ! + allow_wild_char=.true. + j= index(file_template, '*') + _ASSERT ( j==0 .OR. allow_wild_char, "* is not allowed in template") call fill_grads_template ( filename, file_template, & experiment_id='', nymd=nymd, nhms=nhms, _RC ) - inquire(file= trim(filename), EXIST = exist) + if (j==0) then + ! exact file name + inquire(file= trim(filename), EXIST = exist) + else + ! now filename is: file*.nc + call fglob(filename, filename2, rc=status) + exist = (status==0) + if (exist) filename=trim(filename2) + end if _RETURN(_SUCCESS) @@ -913,4 +933,27 @@ subroutine test_conversion end subroutine test_conversion + + subroutine fglob(search_name, filename, rc) ! give the last name + character(len=*), intent(in) :: search_name + character(len=*), intent(INOUT) :: filename + integer, optional, intent(out) :: rc + + character(kind=C_CHAR, len=:), allocatable :: c_search_name + character(kind=C_CHAR, len=512) :: c_filename + integer :: slen, lenmax + + c_search_name = trim(search_name)//C_NULL_CHAR + rc = f_call_c_glob(c_search_name, c_filename, slen) + filename="" + lenmax = len(filename) + if (lenmax < slen) then + if (MAPL_AM_I_ROOT()) write(6,*) 'pathlen vs filename_max_char_len: ', slen, lenmax + _FAIL ('PATHLEN is greater than filename_max_char_len') + end if + if (slen>0) filename(1:slen)=c_filename(1:slen) + + return + end subroutine fglob + end module MAPL_ObsUtilMod diff --git a/base/MAPL_ObsUtil.c b/base/MAPL_ObsUtil.c new file mode 100644 index 000000000000..9323504591ab --- /dev/null +++ b/base/MAPL_ObsUtil.c @@ -0,0 +1,32 @@ +#include +#include +#include + +int glob_C (char*, char*, int*); + +int glob_C (char *pattern, char *filename, int *stringlen) +{ + glob_t globlist; + int error = 1; + int failure = -1; + char *s; + int MAXLEN = 512; // set path length limit + + int j = glob( pattern, GLOB_ERR, NULL, &globlist ); + if ( j == GLOB_NOSPACE || j == GLOB_NOMATCH ) + return (failure); + if ( j == GLOB_ABORTED) + return (error); + + int i = 0; + for (; globlist.gl_pathv[i] ; i++) + // printf("f = %s\n", globlist.gl_pathv[i]); + ; + s = globlist.gl_pathv[--i]; + for (i=0; *(s+i) != '\0'; i++) + *(filename+i) = *(s+i); + *stringlen = i; + + if ( i > MAXLEN ) return error; + return 0; +} diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 93bf1b563c41..f931fe52a12f 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -169,12 +169,8 @@ function make_new_grid(this, unusable, rc) result(grid) _UNUSED_DUMMY(unusable) - !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: bf this%create_basic_grid' grid = this%create_basic_grid(_RC) - !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%create_basic_grid' call this%add_horz_coordinates_from_file(grid,_RC) - !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%add_horz_coordinates_from_file' - _RETURN(_SUCCESS) end function make_new_grid @@ -483,6 +479,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) + if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then call ESMF_TimeSet(currTime, timeString=tmp, _RC) else @@ -718,6 +715,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc endif ! ims is set at here call this%check_and_fill_consistency(_RC) + call lgr%debug(' %a %i5 %i5', 'nx, ny (check_and_fill_consistency) = ', this%nx, this%ny) _RETURN(_SUCCESS) @@ -864,7 +862,6 @@ subroutine check_and_fill_consistency(this, unusable, rc) call this%generate_newnxy(_RC) end if end if - _RETURN(_SUCCESS) contains @@ -1145,43 +1142,48 @@ subroutine generate_newnxy(this,unusable,rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: n + integer :: j, pet_count _UNUSED_DUMMY(unusable) + pet_count = this%nx * this%ny n = this%im_world/this%nx if (n < 2) then - this%nx = generate_new_decomp(this%im_world,this%nx) - deallocate(this%ims) - allocate(this%ims(0:this%nx-1)) - call MAPL_DecomposeDim(this%im_world, this%ims, this%nx) + do j = this%im_world/2, 1, -1 + if ( mod(pet_count, j) == 0 .and. this%im_world/j >= 2 ) then + exit ! found a decomposition + end if + end do + this%nx = j + this%ny = pet_count/j end if + n = this%jm_world/this%ny if (n < 2) then - this%ny = generate_new_decomp(this%jm_world,this%ny) - deallocate(this%jms) - allocate(this%jms(0:this%ny-1)) - call MAPL_DecomposeDim(this%jm_world, this%jms, this%ny) + do j = this%jm_world/2, 1, -1 + if ( mod(pet_count, j) == 0 .and. this%jm_world/j >=2 ) then + exit ! found a decomposition + end if + end do + this%ny = j + this%nx = pet_count/j end if + if ( this%im_world/this%nx < 2 .OR. this%jm_world/this%ny < 2 ) then + _FAIL ('Algorithm failed') + end if + + if (allocated(this%ims)) deallocate(this%ims) + allocate(this%ims(0:this%nx-1)) + call MAPL_DecomposeDim(this%im_world, this%ims, this%nx) + if (allocated(this%jms)) deallocate(this%jms) + allocate(this%jms(0:this%ny-1)) + call MAPL_DecomposeDim(this%jm_world, this%jms, this%ny) + _RETURN(_SUCCESS) end subroutine generate_newnxy - function generate_new_decomp(im,nd) result(n) - integer, intent(in) :: im, nd - integer :: n - logical :: canNotDecomp - - canNotDecomp = .true. - n = nd - do while(canNotDecomp) - if ( (im/n) < 2) then - n = n/2 - else - canNotDecomp = .false. - end if - enddo - end function generate_new_decomp subroutine init_halo(this, unusable, rc) class (SwathGridFactory), target, intent(inout) :: this diff --git a/base/ServerManager.F90 b/base/ServerManager.F90 index fc666df00779..93f160d475bb 100644 --- a/base/ServerManager.F90 +++ b/base/ServerManager.F90 @@ -217,6 +217,7 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server do i = 1, n_oserver_group if ( trim(s_name) =='o_server'//trim(i_to_string(i)) ) then + if (oserver_type_ == 'multicomm' ) then allocate(this%o_server, source = MultiCommServer(this%split_comm%get_subcommunicator(), s_name, npes_out_backend)) @@ -227,11 +228,14 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server npes_out_backend, './pfio_writer.x')) else if (oserver_type_ == 'multigroup' ) then - + allocate(this%o_server, source = MultiGroupServer(this%split_comm%get_subcommunicator(), s_name, npes_out_backend, & with_profiler=with_profiler, rc=status), stat=stat_alloc) _VERIFY(status) _VERIFY(stat_alloc) + if (nodes_out(i) > 0 .and. this%o_server%node_num /= nodes_out(i)) then + _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nodes_out(i)) //" nodes for output server is different from available "//i_to_string(this%o_server%node_num)// " nodes") + endif else allocate(this%o_server, source = MpiServer(this%split_comm%get_subcommunicator(), s_name, with_profiler=with_profiler, rc=status), stat=stat_alloc) diff --git a/benchmarks/io/checkpoint_simulator/README.md b/benchmarks/io/checkpoint_simulator/README.md index d2cba319adc8..4466e69af71f 100644 --- a/benchmarks/io/checkpoint_simulator/README.md +++ b/benchmarks/io/checkpoint_simulator/README.md @@ -5,7 +5,7 @@ The code has the following options and needs an ESMF rc file named checkpoint\_b - "NX:" the x distribution for each face - "NY:" the y distribution for each face - "IM\_WORLD:" the cube resolution -- "LM:" the nubmer of levels +- "LM:" the number of levels - "NUM\_WRITERS:" the number of writing processes either to a single or independent files - "NUM\_ARRAYS:" the number of 3D variables to write to the file - "CHUNK:" whether to chunk, default true @@ -13,7 +13,7 @@ The code has the following options and needs an ESMF rc file named checkpoint\_b - "SPLIT\_FILE:" default false, if true, each writer writes to and independent file - "WRITE\_BARRIER:" default false, add a barrier before each write to for synchronization - "DO\_WRITES:" default true, if false skips writing (so just an mpi test at that point) -- "NTRIAL:" default 1, the number of trials to make writing +- "NTRIALS:" default 1, the number of trials to make writing - "RANDOM\_DATA:" default true, if true will arrays with random data, if false sets the array to the rank of the process -Note that whatever you set NX and NY to the program must be run on 6*NY*NY processors and the number of writers must evenly divide 6*NY +Note that whatever you set NX and NY to the program must be run on `6*NX*NY` processors and the number of writers must evenly divide `6*NY` diff --git a/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 index c82f395c3c11..f2d257c21020 100644 --- a/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 +++ b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 @@ -55,7 +55,7 @@ module mapl_checkpoint_support_mod procedure :: write_level procedure :: write_variable procedure :: reset - end type + end type contains @@ -98,7 +98,7 @@ subroutine set_parameters(this,config_file) this%mpi_time = 0.0 call MPI_COMM_SIZE(MPI_COMM_WORLD,comm_size,status) if (comm_size /= (this%nx*this%ny*6)) call MPI_Abort(mpi_comm_world,error_code,status) - + contains function get_logical_key(config,label,default_val) result(val) @@ -115,7 +115,7 @@ function get_logical_key(config,label,default_val) result(val) val = default_val end if end function - + function get_integer_key(config,label,default_val) result(val) integer :: val type(ESMF_Config), intent(Inout) :: config @@ -130,7 +130,7 @@ function get_integer_key(config,label,default_val) result(val) val = default_val end if end function - + end subroutine subroutine reset(this) @@ -144,7 +144,7 @@ subroutine reset(this) this%time_writing = 0.d0 this%mpi_time = 0.0 end subroutine - + function compute_decomposition(this,axis) result(decomp) integer, allocatable :: decomp(:) class(test_support), intent(inout) :: this @@ -172,7 +172,7 @@ subroutine allocate_n_arrays(this,im,jm) class(test_support), intent(inout) :: this integer, intent(in) :: im integer, intent(in) :: jm - + integer :: n,rank,status character(len=3) :: formatted_int integer :: seed_size @@ -201,7 +201,7 @@ subroutine create_arrays(this) integer, allocatable :: ims(:),jms(:) integer :: rank, status,comm_size,n,i,j,rank_counter,offset,index_offset - call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) + call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) call MPI_Comm_Size(MPI_COMM_WORLD,comm_size,status) allocate(this%bundle(this%num_arrays)) ims = this%compute_decomposition(axis=1) @@ -244,13 +244,13 @@ subroutine create_arrays(this) rank_counter = rank_counter + 1 enddo enddo - enddo - + enddo + end subroutine subroutine create_communicators(this) class(test_support), intent(inout) :: this - + integer :: myid,status,nx0,ny0,color,j,ny_by_writers,local_ny,key local_ny = this%ny*6 @@ -280,7 +280,7 @@ subroutine create_communicators(this) call MPI_BARRIER(mpi_comm_world,status) - + end subroutine subroutine close_file(this) @@ -344,7 +344,7 @@ subroutine create_file(this) status = nf90_def_dim(this%ncid,"lon",this%im_world,xdim) if (this%split_file) then y_size = this%im_world*6/this%num_writers - else + else y_size = this%im_world*6 end if status = nf90_def_dim(this%ncid,"lat",y_size,ydim) @@ -384,7 +384,7 @@ subroutine create_file(this) subroutine write_file(this) class(test_support), intent(inout) :: this integer :: status,i,l - + integer(kind=INT64) :: sub_start,sub_end call MPI_BARRIER(MPI_COMM_WORLD,status) @@ -619,7 +619,7 @@ subroutine write_level(this,var_name,local_var,z_index) io_time = end_time-start_time this%data_volume = this%data_volume+byte_to_mega*4.d0*size(var,kind=INT64) this%time_writing = this%time_writing + real(io_time,kind=REAL64)/real(count_rate,kind=REAL64) - + deallocate(VAR, stat=status) endif ! myiorank @@ -676,13 +676,13 @@ program checkpoint_tester call system_clock(count=start_write) call MPI_Barrier(MPI_COMM_WORLD,status) - call support%create_file() + if (support%do_writes) call support%create_file() call MPI_Barrier(MPI_COMM_WORLD,status) call support%write_file() call MPI_Barrier(MPI_COMM_WORLD,status) - call support%close_file() + if (support%do_writes) call support%close_file() call MPI_Barrier(MPI_COMM_WORLD,status) call system_clock(count=end_time) @@ -707,7 +707,7 @@ program checkpoint_tester all_proc_throughput(i) = real(support%num_writers,kind=REAL32)*average_volume/average_time end if enddo - + call system_clock(count=end_app) application_time = real(end_app - start_app,kind=REAL64)/real(count_rate,kind=REAL64) if (rank == 0) then @@ -741,7 +741,7 @@ program checkpoint_tester std_fs_throughput = sqrt(std_fs_throughput/real(support%n_trials,kind=REAL64)) write(*,'(G16.8,G16.8,G16.8,G16.8)')mean_throughput,std_throughput,mean_fs_throughput,std_fs_throughput end if - - + + call MPI_Finalize(status) end program diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake index eabba677d3b6..4eb0f6a54e91 100644 --- a/cmake/FindESMF.cmake +++ b/cmake/FindESMF.cmake @@ -96,22 +96,22 @@ if(EXISTS ${ESMFMKFILE}) message(WARNING "Static ESMF library (libesmf.a) not found in \ ${ESMF_LIBSDIR}. Try setting USE_ESMF_STATIC_LIBS=OFF") endif() - if(NOT TARGET ESMF) - add_library(ESMF STATIC IMPORTED) + if(NOT TARGET ESMF::ESMF) + add_library(ESMF::ESMF STATIC IMPORTED) endif() else() find_library(ESMF_LIBRARY_LOCATION NAMES esmf PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") message(WARNING "ESMF library not found in ${ESMF_LIBSDIR}.") endif() - if(NOT TARGET ESMF) - add_library(ESMF UNKNOWN IMPORTED) + if(NOT TARGET ESMF::ESMF) + add_library(ESMF::ESMF UNKNOWN IMPORTED) endif() endif() - # Add target alias to facilitate unambiguous linking - if(NOT TARGET ESMF::ESMF) - add_library(ESMF::ESMF ALIAS ESMF) + # Add ESMF as an alias to ESMF::ESMF for backward compatibility + if(NOT TARGET ESMF) + add_library(ESMF ALIAS ESMF::ESMF) endif() # Add ESMF include directories @@ -135,7 +135,7 @@ if(EXISTS ${ESMFMKFILE}) ESMF_F90COMPILEPATHS VERSION_VAR ESMF_VERSION) - set_target_properties(ESMF PROPERTIES + set_target_properties(ESMF::ESMF PROPERTIES IMPORTED_LOCATION "${ESMF_LIBRARY_LOCATION}" INTERFACE_INCLUDE_DIRECTORIES "${ESMF_INCLUDE_DIRECTORIES}" INTERFACE_LINK_LIBRARIES "${ESMF_INTERFACE_LINK_LIBRARIES}") diff --git a/cmake/mapl_acg.cmake b/cmake/mapl_acg.cmake index fe125c68770b..0197f500a55b 100644 --- a/cmake/mapl_acg.cmake +++ b/cmake/mapl_acg.cmake @@ -12,6 +12,10 @@ # INTERNAL_SPECS [file] include file for AddInternalSpec() code (default _Internal___.h) # GET_POINTERS [file] include file for GetPointer() code (default _GetPointer___.h) # DECLARE_POINTERS [file] include file for declaring local pointers (default _DeclarePointer___.h) +# LONG_NAME_PREFIX [string] prefix for long names (default "comp_name") +# +# NOTE: Use of LONG_NAME_PREFIX will require changes to the Fortran code as all the ACG does +# is write Fortran. So, you'll need to define a string in the Fortran for this # ################################################################################################ @@ -22,7 +26,7 @@ function (mapl_acg target specs_file) # This list must align with oneValueArgs above (for later ZIP_LISTS) set (flags -i -x -p -g -d) set (defaults Import Export Internal GetPointer DeclarePointer) - set (multiValueArgs) + set (multiValueArgs LONG_NAME_PREFIX) cmake_parse_arguments (ARGS "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) string (REPLACE "_GridComp" "" component_name ${target}) @@ -35,6 +39,12 @@ function (mapl_acg target specs_file) set (options "") set (suffix_for_generated_include_files "___.h") + # Note: Use the equals sign below. If a space is used, CMake did + # weird things + if (ARGS_LONG_NAME_PREFIX) + list (APPEND options "--longname_glob_prefix=${ARGS_LONG_NAME_PREFIX}") + endif () + # Handle oneValueArgs with no value (Python provides default) foreach (opt flag default IN ZIP_LISTS oneValueArgs flags defaults) diff --git a/components.yaml b/components.yaml index 38ca0c946dc7..bf46f2c95c5d 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.28.1 + tag: v4.29.0 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.44.0 + tag: v3.46.0 develop: develop ecbuild: diff --git a/docs/Ford/ford-ci.md b/docs/Ford/ford-ci.md new file mode 100644 index 000000000000..f1b15f154fb5 --- /dev/null +++ b/docs/Ford/ford-ci.md @@ -0,0 +1,68 @@ +--- +preprocessor: cpp -traditional-cpp -E +src_dir: ../../ +output_dir: ci-doc +search: false +graph: false +coloured_edges: true +graph_maxdepth: 4 +graph_maxnodes: 32 +include: ../../include/ + ../../gFTL/install/GFTL-1.13/include/v1 + ../../gFTL/install/GFTL-1.13/include/v2 +exclude: **/EsmfRegridder.F90 + **/FieldBLAS_IntrinsicFunctions.F90 + **/GeomManager.F90 + **/MaplGeom.F90 + **/Regridder.F90 + **/StateSupplement.F90 +exclude_dir: ../../docs + ../../Doxygen + ../../ESMA_cmake + ../../ESMA_env + ../../build + ../../gFTL + ../../esmf + ../../pFUnit + ../../fArgParse + ../../pFlogger +macro: USE_MPI=1 + BUILD_WITH_PFLOGGER=1 + BUILD_WITH_EXTDATA2G=1 + USE_FLAP=1 + H5_HAVE_PARALLEL=1 + TWO_SIDED_COMM=1 + MAPL_MODE=1 +fixed_length_limit: false +source: true +display: public + private + protected +extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html + iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING +external: remote = https://mathomp4.github.io/esmf +project: MAPL +project_github: https://github.com/GEOS-ESM/MAPL +project_website: https://github.com/GEOS-ESM/MAPL +summary: MAPL is a foundation layer of the GEOS architecture, whose original purpose is to supplement the Earth System Modeling Framework (ESMF) +author: The MAPL Developers +github: https://github.com/GEOS-ESM +email: matthew.thompson@nasa.gov +print_creation_date: true +sort: type-alpha +predocmark_alt: > +predocmark: < +docmark_alt: +docmark: ! +md_extensions: markdown.extensions.toc + markdown.extensions.smarty +extensions: f90 + F90 + pf +fpp_extensions: F90 + pf + F +externalize: true +--- + +{!../../README.md!} diff --git a/docs/tutorial/driver_app/Example_Driver.F90 b/docs/tutorial/driver_app/Example_Driver.F90 index f974d002a624..c4c85f4949e5 100644 --- a/docs/tutorial/driver_app/Example_Driver.F90 +++ b/docs/tutorial/driver_app/Example_Driver.F90 @@ -5,6 +5,10 @@ program Example_Driver use MPI use MAPL +#ifdef __NVCOMPILER + ! Needed by NVIDIA but breaks Intel (see https://github.com/GEOS-ESM/MAPL/pull/2664) + use mapl_CapOptionsMod, only: MAPL_CapOptions +#endif implicit none type (MAPL_Cap) :: cap diff --git a/field_utils/FieldUtilities.F90 b/field_utils/FieldUtilities.F90 index 130d09222f8e..e4f8e2930049 100644 --- a/field_utils/FieldUtilities.F90 +++ b/field_utils/FieldUtilities.F90 @@ -64,7 +64,7 @@ subroutine FieldSet_r8(field,constant_val,rc) if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r4,_RC) f_ptr_r4 = constant_val - else if (type_kind == ESMF_TYPEKIND_R4) then + else if (type_kind == ESMF_TYPEKIND_R8) then call assign_fptr(field,f_ptr_r8,_RC) f_ptr_r8 = constant_val else @@ -87,7 +87,7 @@ subroutine FieldSet_r4(field,constant_val,rc) if (type_kind == ESMF_TYPEKIND_R4) then call assign_fptr(field,f_ptr_r4,_RC) f_ptr_r4 = constant_val - else if (type_kind == ESMF_TYPEKIND_R4) then + else if (type_kind == ESMF_TYPEKIND_R8) then call assign_fptr(field,f_ptr_r8,_RC) f_ptr_r8 = constant_val else diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index f17f0c9b330c..24c0fe6f810e 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -8,6 +8,7 @@ module Test_FieldBLAS use ESMF use pfunit use MAPL_ExceptionHandling + use, intrinsic :: iso_c_binding, only: c_ptr implicit none diff --git a/generic/OpenMP_Support.F90 b/generic/OpenMP_Support.F90 index 57d456c107d6..9cdf0a3ac1c8 100644 --- a/generic/OpenMP_Support.F90 +++ b/generic/OpenMP_Support.F90 @@ -537,8 +537,7 @@ function make_subgridcomps(GridComp, run_entry_points, num_grids, unusable, rc) call ESMF_GridCompGet(GridComp, config=CF, name=comp_name, _RC) call ESMF_InternalStateGet(GridComp, labelList=labels, _RC) -! if(myPET==0) print*,__FILE__,__LINE__, 'internal states labels : <',trim(comp_name), (trim(labels(i)),i=1,size(labels)), '>' -! print*,__FILE__,__LINE__, 'splitting component: <',trim(comp_name),'>' + do i = 1, num_grids associate (gc => subgridcomps(i) ) gc = ESMF_GridCompCreate(name=trim(comp_name), config=CF, petlist=[myPet], & diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index f423b35a21ea..39f3c0b723d1 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -9,7 +9,7 @@ module MAPL_HistoryCollectionMod use MAPL_VerticalDataMod use MAPL_TimeDataMod use HistoryTrajectoryMod - use MaskSamplerGeosatMod + use MaskSamplerGeosatMod use StationSamplerMod use gFTL_StringStringMap use MAPL_EpochSwathMod diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 4eaf29f21c46..c287dae7b07d 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2422,15 +2422,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then - list(n)%trajectory = HistoryTrajectory(cfg,string,clock,_RC) + list(n)%trajectory = HistoryTrajectory(cfg,string,clock,genstate=GENSTATE,_RC) call list(n)%trajectory%initialize(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) IntState%stampoffset(n) = list(n)%trajectory%epoch_frequency elseif (list(n)%sampler_spec == 'mask') then - list(n)%mask_sampler = MaskSamplerGeosat(cfg,string,clock,_RC) + list(n)%mask_sampler = MaskSamplerGeosat(cfg,string,clock,genstate=GENSTATE,_RC) call list(n)%mask_sampler%initialize(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) elseif (list(n)%sampler_spec == 'station') then - list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile), nskip_line=list(n)%stationSkipLine, _RC) - call list(n)%station_sampler%add_metadata_route_handle(list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,_RC) + list(n)%station_sampler = StationSampler (list(n)%bundle, trim(list(n)%stationIdFile), nskip_line=list(n)%stationSkipLine, genstate=GENSTATE, _RC) + call list(n)%station_sampler%add_metadata_route_handle(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then @@ -3451,11 +3451,14 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_grid_case: do n=1,nlist call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) - call MAPL_TimerOn(GENSTATE,"SwathGen") if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then + call MAPL_TimerOn(GENSTATE,"Swath") + call MAPL_TimerOn(GENSTATE,"RegridAccum") call Hsampler%regrid_accumulate(list(n)%xsampler,_RC) + call MAPL_TimerOff(GENSTATE,"RegridAccum") if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then + call MAPL_TimerOn(GENSTATE,"RegenGriddedio") create_mode = PFIO_NOCLOBBER ! defaut no overwrite if (intState%allow_overwrite) create_mode = PFIO_CLOBBER ! add time to items @@ -3473,12 +3476,13 @@ subroutine Run ( gc, import, export, clock, rc ) call list(n)%mGriddedIO%destroy(_RC) call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%xsampler%acc_bundle,timeinfo_uninit,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) call list(n)%items%pop_back() - collection_id = o_Clients%add_hist_collection(list(n)%mGriddedIO%metadata, mode = create_mode) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) + call MAPL_TimerOff(GENSTATE,"RegenGriddedio") endif + call MAPL_TimerOff(GENSTATE,"Swath") end if - call MAPL_TimerOff(GENSTATE,"SwathGen") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) end do epoch_swath_grid_case @@ -3525,7 +3529,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! it's tempting to use the variable "oneMonth" but it does not work ! instead we compute the differece between ! thisMonth and lastMonth and as a new timeInterval - + ! call ESMF_ClockGet(clock,currTime=current_time,_RC) call ESMF_TimeIntervalSet( oneMonth, MM=1, _RC) lastMonth = current_time - oneMonth @@ -3645,6 +3649,7 @@ subroutine Run ( gc, import, export, clock, rc ) if (.not.list(n)%timeseries_output .AND. & list(n)%sampler_spec /= 'station' .AND. & list(n)%sampler_spec /= 'mask') then + IOTYPE: if (list(n)%unit < 0) then ! CFIO call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,_RC) else @@ -3691,14 +3696,24 @@ subroutine Run ( gc, import, export, clock, rc ) end if IOTYPE end if + if (list(n)%sampler_spec == 'station') then call ESMF_ClockGet(clock,currTime=current_time,_RC) + call MAPL_TimerOn(GENSTATE,"Station") + call MAPL_TimerOn(GENSTATE,"AppendFile") call list(n)%station_sampler%append_file(current_time,_RC) + call MAPL_TimerOff(GENSTATE,"AppendFile") + call MAPL_TimerOff(GENSTATE,"Station") elseif (list(n)%sampler_spec == 'mask') then call ESMF_ClockGet(clock,currTime=current_time,_RC) + call MAPL_TimerOn(GENSTATE,"Mask") + call MAPL_TimerOn(GENSTATE,"AppendFile") call list(n)%mask_sampler%append_file(current_time,_RC) + call MAPL_TimerOff(GENSTATE,"AppendFile") + call MAPL_TimerOff(GENSTATE,"Mask") endif + endif OUTTIME if( NewSeg(n) .and. list(n)%unit /= 0 .and. list(n)%duration /= 0 ) then @@ -3724,20 +3739,20 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_regen_grid: do n=1,nlist call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) - call MAPL_TimerOn(GENSTATE,"Swath regen") if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then + call MAPL_TimerOn(GENSTATE,"Swath") if( ESMF_AlarmIsRinging ( Hsampler%alarm ) .and. .not. ESMF_AlarmIsRinging(list(n)%end_alarm) ) then - + call MAPL_TimerOn(GENSTATE,"RegenGrid") key_grid_label = list(n)%output_grid_label call Hsampler%destroy_rh_regen_ogrid ( key_grid_label, IntState%output_grids, list(n)%xsampler, _RC ) - pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,Hsampler%tunit, & ogrid=pgrid,vdata=list(n)%vdata,_RC) if( MAPL_AM_I_ROOT() ) write(6,'(//)') + call MAPL_TimerOff(GENSTATE,"RegenGrid") endif + call MAPL_TimerOff(GENSTATE,"Swath") end if - call MAPL_TimerOff(GENSTATE,"Swath regen") call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) end do epoch_swath_regen_grid @@ -3754,16 +3769,24 @@ subroutine Run ( gc, import, export, clock, rc ) WRITELOOP: do n=1,nlist call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) - call MAPL_TimerOn(GENSTATE,"Write Timeseries") + if (list(n)%timeseries_output) then + call MAPL_TimerOn(GENSTATE,"Trajectory") + call MAPL_TimerOn(GENSTATE,"RegridAccum") call list(n)%trajectory%regrid_accumulate(_RC) + call MAPL_TimerOff(GENSTATE,"RegridAccum") if( ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) ) then + call MAPL_TimerOn(GENSTATE,"AppendFile") call list(n)%trajectory%append_file(current_time,_RC) call list(n)%trajectory%close_file_handle(_RC) + call MAPL_TimerOff(GENSTATE,"AppendFile") if ( .not. ESMF_AlarmIsRinging(list(n)%end_alarm) ) then + call MAPL_TimerOn(GENSTATE,"RegenLS") call list(n)%trajectory%destroy_rh_regen_LS (_RC) + call MAPL_TimerOff(GENSTATE,"RegenLS") end if end if + call MAPL_TimerOff(GENSTATE,"Trajectory") end if if( Writing(n) .and. list(n)%unit < 0) then @@ -3772,7 +3795,6 @@ subroutine Run ( gc, import, export, clock, rc ) end if - call MAPL_TimerOff(GENSTATE,"Write Timeseries") call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) enddo WRITELOOP diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 index 5674a1b2f1ca..21e9d1251379 100644 --- a/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 @@ -20,6 +20,7 @@ module MaskSamplerGeosatMod use MPI use pFIO_FileMetadataMod, only : FileMetadata use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter + use MAPL_GenericMod, only : MAPL_MetaComp, MAPL_TimerOn, MAPL_TimerOff use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 use pflogger, only: Logger, logging @@ -76,6 +77,7 @@ module MaskSamplerGeosatMod real(kind=REAL64), allocatable :: lats(:) integer, allocatable :: recvcounts(:) integer, allocatable :: displs(:) + type(MAPL_MetaComp), pointer :: GENSTATE real(kind=ESMF_KIND_R8), pointer:: obsTime(:) real(kind=ESMF_KIND_R8), allocatable:: t_alongtrack(:) @@ -88,11 +90,11 @@ module MaskSamplerGeosatMod integer :: obsfile_Te_index logical :: is_valid contains - procedure :: initialize + procedure :: initialize => initialize_ procedure :: add_metadata procedure :: create_file_handle procedure :: close_file_handle - procedure :: append_file => regrid_accumulate_append_file + procedure :: append_file => regrid_append_file ! procedure :: create_new_bundle procedure :: create_grid => create_Geosat_grid_find_mask procedure :: compute_time_for_current @@ -104,15 +106,18 @@ module MaskSamplerGeosatMod interface - module function MaskSamplerGeosat_from_config(config,string,clock,rc) result(mask) + module function MaskSamplerGeosat_from_config(config,string,clock,GENSTATE,rc) result(mask) + use BinIOMod + use pflogger, only : Logger, logging type(MaskSamplerGeosat) :: mask type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: string type(ESMF_Clock), intent(in) :: clock + type(MAPL_MetaComp), pointer, intent(in), optional :: GENSTATE integer, optional, intent(out) :: rc end function MaskSamplerGeosat_from_config - module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) + module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) class(MaskSamplerGeosat), intent(inout) :: this type(GriddedIOitemVector), optional, intent(inout) :: items type(ESMF_FieldBundle), optional, intent(inout) :: bundle @@ -120,9 +125,12 @@ module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) type(VerticalData), optional, intent(inout) :: vdata logical, optional, intent(in) :: reinitialize integer, optional, intent(out) :: rc - end subroutine initialize + end subroutine initialize_ module subroutine create_Geosat_grid_find_mask(this, rc) + use pflogger, only: Logger, logging + implicit none + class(MaskSamplerGeosat), intent(inout) :: this integer, optional, intent(out) :: rc end subroutine create_Geosat_grid_find_mask @@ -150,13 +158,15 @@ module subroutine close_file_handle(this,rc) integer, optional, intent(out) :: rc end subroutine close_file_handle - module subroutine regrid_accumulate_append_file(this,current_time,rc) + module subroutine regrid_append_file(this,current_time,rc) class(MaskSamplerGeosat), intent(inout) :: this type(ESMF_Time), intent(inout) :: current_time integer, optional, intent(out) :: rc - end subroutine regrid_accumulate_append_file + end subroutine regrid_append_file module function compute_time_for_current(this,current_time,rc) result(rtime) + use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF + class(MaskSamplerGeosat), intent(inout) :: this type(ESMF_Time), intent(in) :: current_time integer, optional, intent(out) :: rc diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 index 6201f50e2754..f19e204d9c04 100644 --- a/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 @@ -5,9 +5,16 @@ implicit none contains - module procedure MaskSamplerGeosat_from_config +module function MaskSamplerGeosat_from_config(config,string,clock,GENSTATE,rc) result(mask) use BinIOMod use pflogger, only : Logger, logging + type(MaskSamplerGeosat) :: mask + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string + type(ESMF_Clock), intent(in) :: clock + type(MAPL_MetaComp), pointer, intent(in), optional :: GENSTATE + integer, optional, intent(out) :: rc + type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: epoch_frequency type(ESMF_TimeInterval) :: obs_time_span @@ -27,6 +34,8 @@ mask%clock=clock mask%grid_file_name='' + if (present(GENSTATE)) mask%GENSTATE => GENSTATE + call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) if (mapl_am_I_root()) write(6,*) 'string', string @@ -94,13 +103,21 @@ 105 format (1x,a,2x,a) 106 format (1x,a,2x,i8) - end procedure MaskSamplerGeosat_from_config +end function MaskSamplerGeosat_from_config ! !-- integrate both initialize and reinitialize ! - module procedure initialize +module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) + class(MaskSamplerGeosat), intent(inout) :: this + type(GriddedIOitemVector), optional, intent(inout) :: items + type(ESMF_FieldBundle), optional, intent(inout) :: bundle + type(TimeData), optional, intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + logical, optional, intent(in) :: reinitialize + integer, optional, intent(out) :: rc + integer :: status type(ESMF_Grid) :: grid type(variable) :: v @@ -131,12 +148,16 @@ _RETURN(_SUCCESS) - end procedure initialize +end subroutine initialize_ - module procedure create_Geosat_grid_find_mask + module subroutine create_Geosat_grid_find_mask(this, rc) use pflogger, only: Logger, logging implicit none + + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + type(Logger), pointer :: lgr real(ESMF_KIND_R8), pointer :: ptAT(:) type(ESMF_routehandle) :: RH @@ -324,7 +345,6 @@ obs_lats = lats_ds * MAPL_DEGREES_TO_RADIANS_R8 nx = size ( lons_ds ) allocate ( II(nx), JJ(nx), _STAT ) - call MPI_Barrier(mpic, status) call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) call ESMF_VMBarrier (vm, _RC) @@ -354,7 +374,6 @@ call ESMF_FieldHaloStore (fieldI4, routehandle=RH_halo, _RC) call ESMF_FieldHalo (fieldI4, routehandle=RH_halo, _RC) - call ESMF_VMBarrier (vm, _RC) k=0 do i=eLB(1), eUB(1) @@ -411,7 +430,7 @@ lons(i) = lons_ptr (ix, jx) lats(i) = lats_ptr (ix, jx) end do - call ESMF_VMBarrier (vm, _RC) + iroot=0 if (mapl_am_i_root()) then @@ -453,10 +472,13 @@ iroot, mpic, ierr ) _RETURN(_SUCCESS) - end procedure create_Geosat_grid_find_mask + end subroutine create_Geosat_grid_find_mask -module procedure add_metadata +module subroutine add_metadata(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + type(variable) :: v type(ESMF_Field) :: field integer :: fieldCount @@ -527,11 +549,11 @@ endif if (field_rank==2) then vdims = "mask_index,time" - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[this%npt_mask_tot,1]) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) else if (field_rank==3) then vdims = "lev,mask_index,time" call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) end if call v%add_attribute('units', trim(units)) call v%add_attribute('long_name', trim(long_name)) @@ -543,12 +565,16 @@ deallocate (fieldNameList, _STAT) _RETURN(_SUCCESS) - end procedure add_metadata + end subroutine add_metadata - module procedure regrid_accumulate_append_file - ! + module subroutine regrid_append_file(this,current_time,rc) implicit none + + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(inout) :: current_time + integer, optional, intent(out) :: rc + ! integer :: status integer :: fieldCount integer :: ub(1), lb(1) @@ -626,15 +652,16 @@ iy = this%index_mask(2,j) p_dst_2d(j) = p_src_2d(ix, iy) end do - call MPI_Barrier(mpic, status) nsend = nx call MPI_gatherv ( p_dst_2d, nsend, MPI_REAL, & p_dst_2d_full, this%recvcounts, this%displs, MPI_REAL,& iroot, mpic, ierr ) + call MAPL_TimerOn(this%GENSTATE,"put2D") if (mapl_am_i_root()) then call this%formatter%put_var(item%xname,p_dst_2d_full,& start=[1,this%obs_written],count=[this%npt_mask_tot,1],_RC) end if + call MAPL_TimerOff(this%GENSTATE,"put2D") else if (rank==3) then call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) @@ -648,12 +675,12 @@ p_dst_3d(m) = p_src_3d(ix, iy, k) end do end do - call MPI_Barrier(mpic, status) !! write(6,'(2x,a,2x,i5,3x,10f8.1)') 'pet, p_dst_3d(j)', mypet, p_dst_3d(::10) nsend = nx * nz call MPI_gatherv ( p_dst_3d, nsend, MPI_REAL, & p_dst_3d_full, recvcounts_3d, displs_3d, MPI_REAL,& iroot, mpic, ierr ) + call MAPL_TimerOn(this%GENSTATE,"put3D") if (mapl_am_i_root()) then allocate(arr(nz, this%npt_mask_tot), _STAT) arr=reshape(p_dst_3d_full,[nz,this%npt_mask_tot],order=[1,2]) @@ -662,6 +689,7 @@ !note: lev,station,time deallocate(arr, _STAT) end if + call MAPL_TimerOff(this%GENSTATE,"put3D") else _FAIL('grid2LS regridder: rank > 3 not implemented') end if @@ -671,11 +699,14 @@ end do _RETURN(_SUCCESS) - end procedure regrid_accumulate_append_file + end subroutine regrid_append_file - module procedure create_file_handle + module subroutine create_file_handle(this,filename,rc) + class(MaskSamplerGeosat), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(out) :: rc type(variable) :: v integer :: status, j real(kind=REAL64), allocatable :: x(:) @@ -703,10 +734,13 @@ ! call this%formatter%put_var('mask_name',this%mask_name,_RC) _RETURN(_SUCCESS) - end procedure create_file_handle + end subroutine create_file_handle + + module subroutine close_file_handle(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc - module procedure close_file_handle integer :: status if (trim(this%ofile) /= '') then if (mapl_am_i_root()) then @@ -714,11 +748,16 @@ end if end if _RETURN(_SUCCESS) - end procedure close_file_handle + end subroutine close_file_handle - module procedure compute_time_for_current + module function compute_time_for_current(this,current_time,rc) result(rtime) use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(kind=ESMF_KIND_R8) :: rtime + integer :: status type(ESMF_TimeInterval) :: t_interval class(Variable), pointer :: var @@ -744,7 +783,7 @@ rtime = rtime_1d(1) _RETURN(_SUCCESS) - end procedure compute_time_for_current + end function compute_time_for_current diff --git a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 index 5257f94c375f..8a94d5ef5665 100644 --- a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 @@ -4,11 +4,16 @@ module StationSamplerMod use MAPL_ErrorHandlingMod use LocStreamFactoryMod use pFIO + use MAPL_GriddedIOItemMod + use MAPL_GriddedIOItemVectorMod use MAPL_TimeDataMod use MAPL_VerticalDataMod use MAPL_BaseMod use MAPL_CommsMod use MAPL_LocstreamRegridderMod + use MAPL_GenericMod, only : MAPL_MetaComp, MAPL_TimerOn, MAPL_TimerOff + use MPI, only : MPI_INTEGER, MPI_REAL, MPI_REAL8 + use, intrinsic :: iso_fortran_env, only: INT64 use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 use, intrinsic :: iso_c_binding, only: C_NULL_CHAR @@ -19,22 +24,32 @@ module StationSamplerMod type :: StationSampler private type(LocStreamFactory) :: LSF - type(ESMF_LocStream) :: esmf_ls + type(ESMF_LocStream) :: LS_rt + type(ESMF_LocStream) :: LS_chunk + type(ESMF_LocStream) :: LS_ds type(LocstreamRegridder) :: regridder + type(ESMF_RouteHandle) :: RH + type(GriddedIOitemVector) :: items + logical :: do_vertical_regrid + logical :: level_by_level + type(MAPL_MetaComp), pointer :: GENSTATE + integer :: nstation integer, allocatable :: station_id(:) character(len=ESMF_MAXSTR), allocatable :: station_name(:) character(len=ESMF_MAXSTR), allocatable :: station_fullname(:) + character(len=ESMF_MAXSTR) :: index_name_x real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: elevs(:) type(ESMF_FieldBundle) :: bundle - type(FileMetadata) :: fmd + type(FileMetadata) :: metadata type(NetCDF4_FileFormatter) :: formatter type(VerticalData) :: vdata type(TimeData) :: time_info character(LEN=ESMF_MAXPATHLEN) :: ofile integer :: obs_written + contains procedure :: add_metadata_route_handle procedure :: create_file_handle @@ -42,6 +57,7 @@ module StationSamplerMod procedure :: append_file procedure :: get_file_start_time procedure :: compute_time_for_current + procedure :: create_variable => create_metadata_variable end type StationSampler interface StationSampler @@ -50,14 +66,29 @@ module StationSamplerMod contains - function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) + function new_StationSampler_readfile (bundle, filename, nskip_line, GENSTATE, rc) result(sampler) use pflogger, only : Logger, logging implicit none type(StationSampler) :: sampler + type(ESMF_FieldBundle), intent(in) :: bundle character(len=*), intent(in) :: filename - integer, optional, intent(in) :: nskip_line + integer, optional, intent(in) :: nskip_line + type(MAPL_MetaComp), pointer, intent(in), optional :: GENSTATE integer, optional, intent(out) :: rc + type(ESMF_VM) :: vm + integer :: mypet, petcount, mpic + type(ESMF_grid) :: grid + integer, allocatable :: sendcount(:), displs(:) + integer :: recvcount + integer :: is, ie, ierr + integer :: M, N, ip + integer :: arr(1) + integer :: nx, nx2, nx_sum + + real(REAL64), allocatable :: lons_chunk(:) + real(REAL64), allocatable :: lats_chunk(:) + integer :: unit, ios, nstation, status integer :: i, j, k, ncount logical :: con1, con2 @@ -73,155 +104,226 @@ function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) ! ["name_short lat lon elev name_full"] ! - open(newunit=unit, file=trim(filename), form='formatted', & - access='sequential', status='old', _IOSTAT) - ios=0 - nstation=0 - nskip=0 - if (present(nskip_line)) then - nskip=nskip_line - end if - if (nskip>0) then - do i=1, nskip - read(unit, *) - end do - end if - read(unit, '(a100)', IOSTAT=ios) line - call count_substring(line, ',', ncount, _RC) - con1= (ncount>=2 .AND. ncount<=4).OR.(ncount==0) - _ASSERT(con1, 'string sequence in Aeronet file not supported') - if (ncount==0) then - seq='AFFFA' - elseif (ncount==2) then - seq='AFF' - elseif (ncount==3) then - seq='AFFF' - elseif (ncount==4) then - CH1=line(1:1) - con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') - con2= CH1>='0'.AND.CH1<='9' - if (con1) then - seq='AIFFF' - else - if (con2) then - seq='IAFFF' + lgr => logging%get_logger('HISTORY.sampler') + if ( MAPL_AM_I_ROOT() ) then + open(newunit=unit, file=trim(filename), form='formatted', & + access='sequential', status='old', _IOSTAT) + ios=0 + nstation=0 + nskip=0 + if (present(nskip_line)) then + nskip=nskip_line + end if + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + read(unit, '(a100)', IOSTAT=ios) line + call count_substring(line, ',', ncount, _RC) + con1= (ncount>=2 .AND. ncount<=4).OR.(ncount==0) + _ASSERT(con1, 'string sequence in Aeronet file not supported') + if (ncount==0) then + seq='AFFFA' + elseif (ncount==2) then + seq='AFF' + elseif (ncount==3) then + seq='AFFF' + elseif (ncount==4) then + CH1=line(1:1) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + con2= CH1>='0'.AND.CH1<='9' + if (con1) then + seq='AIFFF' else - _ASSERT(.false., 'string sequence in Aeronet file not supported') + if (con2) then + seq='IAFFF' + else + _ASSERT(.false., 'string sequence in Aeronet file not supported') + end if end if end if - end if - rewind(unit) - if (nskip>0) then - do i=1, nskip - read(unit, *) + rewind(unit) + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + ios=0 + do while (ios==0) + read(unit, '(a100)', IOSTAT=ios) line + if (ios==0) nstation=nstation+1 end do - end if - ios=0 - do while (ios==0) - read(unit, '(a100)', IOSTAT=ios) line - if (ios==0) nstation=nstation+1 - end do - sampler%nstation=nstation - allocate(sampler%station_id(nstation), _STAT) - allocate(sampler%station_name(nstation), _STAT) - allocate(sampler%station_fullname(nstation), _STAT) - allocate(sampler%lons(nstation), _STAT) - allocate(sampler%lats(nstation), _STAT) - allocate(sampler%elevs(nstation), _STAT) - - rewind(unit) - if (nskip>0) then - do i=1, nskip - read(unit, *) + sampler%nstation=nstation + allocate(sampler%station_id(nstation), _STAT) + allocate(sampler%station_name(nstation), _STAT) + allocate(sampler%station_fullname(nstation), _STAT) + allocate(sampler%lons(nstation), _STAT) + allocate(sampler%lats(nstation), _STAT) + allocate(sampler%elevs(nstation), _STAT) + + rewind(unit) + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + do i=1, nstation + if(seq=='IAFFF') then + read(unit, *) & + sampler%station_id(i), & + sampler%station_name(i), & + sampler%lons(i), & + sampler%lats(i) + elseif(seq=='AIFFF') then + read(unit, *) & + sampler%station_name(i), & + sampler%station_id(i), & + sampler%lons(i), & + sampler%lats(i) + elseif(trim(seq)=='AFF' .OR. trim(seq)=='AFFF') then + !!write(6,*) 'i=', i + line='' + read(unit, '(a100)') line + !!write(6,*) 'line=', trim(line) + call CSV_read_line_with_CH_I_R(line, & + sampler%station_name(i), & + sampler%lons(i), & + sampler%lats(i), _RC) + sampler%station_id(i)=i + elseif(trim(seq)=='AFFFA') then + ! NOAA GHCNd + ! Ex: 'CHM00054511 39.9330 116.2830 55.0 BEIJING GSN 54511' + read(unit, *) & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + sampler%station_id(i)=i + backspace(unit) + read(unit, '(a100)', IOSTAT=ios) line + j=index(line, '.', BACK=.true.) + line2=line(j+1:) + k=len(line2) + line='' + do j=1, k + CH1=line2(j:j) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + if (con1) exit + enddo + read(line2(j:k), '(a100)') line + line2=trim(line) + k=len(line2) + line='' + do j=1, k + CH1=line2(j:j) + con1= (CH1>='0' .AND. CH1<='9') + if (con1) exit + enddo + if (j>k) j=k + sampler%station_fullname(i) = trim(line2(1:j-1)) + end if end do + close(unit) + + write(6,*) 'nstation=', nstation + write(6,*) 'sampler%station_name(1:2) : ', & + trim(sampler%station_name(1)), trim(sampler%station_name(2)) + write(6,*) 'sampler%lons(1:2) : ',& + sampler%lons(1:2) + write(6,*) 'sampler%lats(1:2) : ',& + sampler%lats(1:2) + else + nstation=0 + sampler%nstation = 0 + allocate(sampler%station_id(nstation), _STAT) + allocate(sampler%station_name(nstation), _STAT) + allocate(sampler%station_fullname(nstation), _STAT) + allocate(sampler%lons(nstation), _STAT) + allocate(sampler%lats(nstation), _STAT) + allocate(sampler%elevs(nstation), _STAT) end if - do i=1, nstation - if(seq=='IAFFF') then - read(unit, *) & - sampler%station_id(i), & - sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i) - elseif(seq=='AIFFF') then - read(unit, *) & - sampler%station_name(i), & - sampler%station_id(i), & - sampler%lons(i), & - sampler%lats(i) - elseif(trim(seq)=='AFF' .OR. trim(seq)=='AFFF') then - !!write(6,*) 'i=', i - line='' - read(unit, '(a100)') line - !!write(6,*) 'line=', trim(line) - call CSV_read_line_with_CH_I_R(line, & - sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i), _RC) - sampler%station_id(i)=i - elseif(trim(seq)=='AFFFA') then - ! NOAA GHCNd - ! Ex: 'CHM00054511 39.9330 116.2830 55.0 BEIJING GSN 54511' - read(unit, *) & - sampler%station_name(i), & - sampler%lats(i), & - sampler%lons(i) - sampler%station_id(i)=i - backspace(unit) - read(unit, '(a100)', IOSTAT=ios) line - j=index(line, '.', BACK=.true.) - line2=line(j+1:) - k=len(line2) - line='' - do j=1, k - CH1=line2(j:j) - con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') - if (con1) exit - enddo - read(line2(j:k), '(a100)') line - line2=trim(line) - k=len(line2) - line='' - do j=1, k - CH1=line2(j:j) - con1= (CH1>='0' .AND. CH1<='9') - if (con1) exit - enddo - if (j>k) j=k - sampler%station_fullname(i) = trim(line2(1:j-1)) - end if - end do - close(unit) - lgr => logging%get_logger('HISTORY.sampler') - call lgr%debug('%a %i8', 'nstation=', nstation) - call lgr%debug('%a %a %a', 'sampler%station_name(1:2) : ', & - trim(sampler%station_name(1)), trim(sampler%station_name(2))) - call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& - sampler%lons(1),sampler%lons(2)) - call lgr%debug('%a %f8.2 %f8.2', 'sampler%lats(1:2) : ',& - sampler%lats(1),sampler%lats(2)) - - !__ 2. create LocStreamFactory, then esmf_ls including route_handle + sampler%index_name_x = 'station_index' + if (present(GENSTATE)) sampler%GENSTATE => GENSTATE + + + !__ 2. create LocStreamFactory, then LS_rt including route_handle ! - sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) - sampler%esmf_ls = sampler%LSF%create_locstream(_RC) + ! grid_A: LS_rt : on root + ! grid_B: LS_chunk : uniform on cores + ! grid_C: LS_ds : bg=CS ! + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + call MAPL_CommsBcast(vm, DATA=sampler%nstation, N=1, ROOT=MAPL_Root, _RC) + + nx_sum = sampler%nstation + ip = mypet ! 0 to M-1 + N = nx_sum + M = petCount + recvcount = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) + call lgr%debug('%a %i12 %i12', 'ip, recvcount', ip, recvcount) + + allocate ( sendcount (petCount) ) + allocate ( displs (petCount) ) + do ip=0, M-1 + sendcount(ip+1) = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) + end do + displs(1)=0 + do i = 2, petCount + displs(i) = displs(i-1) + sendcount(i-1) + end do + + allocate ( lons_chunk (recvcount) ) + allocate ( lats_chunk (recvcount) ) + + arr(1) = recvcount + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx2, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + _ASSERT( nx2 == nx_sum, 'Erorr in recvcount' ) + + call MPI_Scatterv( sampler%lons, sendcount, & + displs, MPI_REAL8, lons_chunk, & + recvcount, MPI_REAL8, 0, mpic, ierr) + + call MPI_Scatterv( sampler%lats, sendcount, & + displs, MPI_REAL8, lats_chunk, & + recvcount, MPI_REAL8, 0, mpic, ierr) + + ! -- root + sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) + sampler%LS_rt = sampler%LSF%create_locstream(_RC) + + ! -- chunk + sampler%LSF = LocStreamFactory(lons_chunk,lats_chunk,_RC) + sampler%LS_chunk = sampler%LSF%create_locstream_on_proc(_RC) + + ! -- distributed + call ESMF_FieldBundleGet(bundle,grid=grid,_RC) + sampler%LS_ds = sampler%LSF%create_locstream_on_proc(grid=grid,_RC) + ! init ofile sampler%ofile='' sampler%obs_written=0 + sampler%level_by_level = .false. _RETURN(_SUCCESS) end function new_StationSampler_readfile - subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) + subroutine add_metadata_route_handle (this,items,bundle,timeInfo,vdata,rc) class(StationSampler), intent(inout) :: this - type(ESMF_FieldBundle), intent(in) :: bundle - type(TimeData), intent(inout) :: timeInfo + type(GriddedIOitemVector), optional, intent(inout) :: items + type(ESMF_FieldBundle), optional, intent(inout) :: bundle + type(TimeData), optional, intent(inout) :: timeInfo type(VerticalData), optional, intent(inout) :: vdata integer, optional, intent(out) :: rc type(variable) :: v + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item type(ESMF_Grid) :: grid type(ESMF_Field) :: field integer :: fieldCount @@ -232,98 +334,145 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) integer :: lb(ESMF_MAXDIM) logical :: do_vertical_regrid integer :: status - integer :: i + integer :: i, lm character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims - !__ 1. metadata add_dimension, - ! add_variable for time, latlon, station + type(ESMF_Field) :: src_field, chunk_field + real(REAL32), pointer :: pt1(:), pt2(:) + + + !__ 1. filemetadata: + ! add_dimension, add_variable for latlon, station ! - this%bundle = bundle - nstation = this%nstation + if(present(bundle)) this%bundle=bundle + if(present(items)) this%items=items + if(present(timeInfo)) this%time_info=timeInfo if (present(vdata)) then this%vdata = vdata else this%vdata = VerticalData(_RC) end if - call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! specify lev in fmd + nstation = this%nstation + + call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) ! specify lev in fmd do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then call this%vdata%get_interpolating_variable(this%bundle,_RC) endif - call timeInfo%add_time_to_metadata(this%fmd,_RC) ! specify time in fmd + call timeInfo%add_time_to_metadata(this%metadata,_RC) ! specify time in fmd this%time_info = timeInfo - call this%fmd%add_dimension('station_index',nstation) + call this%metadata%add_dimension('station_index',nstation) v = Variable(type=pFIO_REAL32, dimensions='station_index') call v%add_attribute('long_name','longitude') call v%add_attribute('unit','degree_east') - call this%fmd%add_variable('longitude',v) + call this%metadata%add_variable('longitude',v) v = Variable(type=pFIO_REAL32, dimensions='station_index') call v%add_attribute('long_name','latitude') call v%add_attribute('unit','degree_north') - call this%fmd%add_variable('latitude',v) + call this%metadata%add_variable('latitude',v) v = Variable(type=pFIO_INT32, dimensions='station_index') - call this%fmd%add_variable('station_id',v) + call this%metadata%add_variable('station_id',v) v = Variable(type=pFIO_STRING, dimensions='station_index') call v%add_attribute('long_name','station name') - call this%fmd%add_variable('station_name',v) + call this%metadata%add_variable('station_name',v) - !__ 2. filemetadata: extract field from bundle, add_variable + !__ 2. filemetadata: + ! create varible with names in item%xname; see create_metadata_variable ! - call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount), _STAT) - call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) - do i=1, fieldCount - var_name=trim(fieldNameList(i)) - call ESMF_FieldBundleGet(bundle,var_name,field=field,_RC) - call ESMF_FieldGet(field,rank=field_rank,_RC) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) - else - long_name = var_name - endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) - else - units = 'unknown' - endif - if (field_rank==2) then - vdims = "station_index,time" - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[nstation,1]) - else if (field_rank==3) then - vdims = "lev,station_index,time" - call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call this%create_variable(item%xname,_RC) + else if (item%itemType == ItemTypeVector) then + call this%create_variable(item%xname,_RC) + call this%create_variable(item%yname,_RC) end if - call v%add_attribute('units', trim(units)) - call v%add_attribute('long_name', trim(long_name)) - call v%add_attribute('missing_value', MAPL_UNDEF) - call v%add_attribute('_FillValue', MAPL_UNDEF) - call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) - call this%fmd%add_variable(trim(var_name),v,_RC) - end do - deallocate (fieldNameList) + call iter%next() + enddo - !__ 3. locstream route handle + !__ 3. route handle CS --> LS_ds ! call ESMF_FieldBundleGet(bundle,grid=grid,_RC) - this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) + this%regridder = LocStreamRegridder(grid,this%LS_ds,_RC) + !__ 4. route handle LS_ds --> LS_chunk + ! + src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + chunk_field = ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + call ESMF_FieldGet( src_field, localDE=0, farrayPtr=pt1, _RC ) + call ESMF_FieldGet( chunk_field, localDE=0, farrayPtr=pt2, _RC ) + pt1=0.0 + pt2=0.0 + call ESMF_FieldRedistStore(src_field,chunk_field,this%RH,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(chunk_field,noGarbage=.true.,_RC) _RETURN(_SUCCESS) end subroutine add_metadata_route_handle + subroutine create_metadata_variable(this,vname,rc) + class(StationSampler), intent(inout) :: this + character(len=*), intent(in) :: vname + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + type(variable) :: v + logical :: is_present + integer :: field_rank, status + character(len=ESMF_MAXSTR) :: var_name,long_name,units,vdims + integer :: rank,lb(1),ub(1) + integer :: k, ig + integer, allocatable :: chunksizes(:) + + call ESMF_FieldBundleGet(this%bundle,vname,field=field,_RC) + call ESMF_FieldGet(field,name=var_name,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + long_name = var_name + if ( is_present ) then + call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, _RC) + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + units = 'unknown' + if ( is_present ) then + call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, _RC) + endif + + vdims = "station_index,time" + select case (field_rank) + case(2) + chunksizes = [this%nstation,1] + case(3) + vdims = "lev,"//trim(vdims) + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + chunksizes = [ub(1)-lb(1)+1,1,1] + case default + _FAIL('unsupported rank') + end select + v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) + + call v%add_attribute('units',trim(units)) + call v%add_attribute('long_name',trim(long_name)) + call v%add_attribute('missing_value',MAPL_UNDEF) + call v%add_attribute('_FillValue',MAPL_UNDEF) + call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%metadata%add_variable(trim(var_name),v,_RC) + + _RETURN(_SUCCESS) + end subroutine create_metadata_variable + + + subroutine append_file(this,current_time,rc) class(StationSampler), intent(inout) :: this type(ESMF_Time), intent(in) :: current_time @@ -332,74 +481,220 @@ subroutine append_file(this,current_time,rc) integer :: status integer :: fieldCount integer :: ub(1), lb(1) - type(ESMF_Field) :: src_field,dst_field - real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) - real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Grid) :: grid + type(ESMF_Field) :: src_field ! ,dst_field + type(ESMF_Field) :: new_src_field,new_dst_field + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:), qin_3d(:,:,:) ! source + real(kind=REAL32), pointer :: p_dst_3d(:,:) ! destination + real(kind=REAL32), pointer :: p_ds_3d(:,:),p_ds_2d(:) ! distributed LS + real(kind=REAL32), pointer :: p_chunk_3d(:,:),p_chunk_2d(:) ! chunk LS + real(kind=REAL32), pointer :: p_rt_3d(:,:),p_rt_2d(:) ! root LS + real(kind=REAL32), pointer :: p_rt_3d_aux(:,:) + real(kind=REAL32), allocatable :: p_new_lev(:,:,:) + real(kind=REAL32), allocatable :: p_dst_t(:,:) + real(kind=REAL32), allocatable :: arr(:,:) - character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) character(len=ESMF_MAXSTR) :: xname real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) - integer :: i, rank - integer :: nx, nz + + integer :: rank + integer :: i, j, k, nz, lm + + type(ESMF_VM) :: vm + integer :: mypet, petcount, mpic, iroot + integer :: n0, nx, nx2 + integer :: na, nb, nx_sum, nsend, nsend_v + + ! intermediate fields as placeholder + type(ESMF_Field) :: field_ds_2d + type(ESMF_Field) :: field_chunk_2d + type(ESMF_Field) :: field_chunk_3d + + integer :: sec + integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch + logical :: EX ! file + logical :: zero_obs + integer, allocatable :: recvcount(:), sendcount(:), displs(:) + integer, allocatable :: recvcount_v(:), displs_v(:) + integer :: is, ie, ierr + integer :: M, N, ip this%obs_written=this%obs_written+1 !__ 1. put_var: time variable ! rtimes = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(_RC) - end if if (mapl_am_i_root()) then call this%formatter%put_var('time',rtimes(1:1),& start=[this%obs_written],count=[1],_RC) end if - !__ 2. put_var: ungridded_dim from src to dst [regrid] + + !__ 2. regrid + put_var: + ! ungridded_dim from src to dst [regrid] ! - call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount), _STAT) - call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) - do i=1, fieldCount - xname=trim(fieldNameList(i)) - call ESMF_FieldBundleGet(this%bundle,xname,field=src_field,_RC) - call ESMF_FieldGet(src_field,rank=rank,_RC) - if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) - dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname, & - typekind=ESMF_TYPEKIND_R4,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) - call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) - if (mapl_am_i_root()) then - call this%formatter%put_var(xname,p_dst_2d,& - start=[1,this%obs_written],count=[this%nstation,1],_RC) - end if - call ESMF_FieldDestroy(dst_field,nogarbage=.true.) - else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - if (this%vdata%lm/=(ub(1)-lb(1)+1)) then - lb(1)=1 - ub(1)=this%vdata%lm - end if - dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname,& - typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) - call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) - if (mapl_am_i_root()) then - nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx), _STAT) - arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) - call this%formatter%put_var(xname,arr,& - start=[1,1,this%obs_written],count=[nz,nx,1],_RC) - !note: lev,station,time - deallocate(arr) - end if - call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + ! caution about zero-sized array for MPI + ! redist + ! + nx_sum = this%nstation + lm = this%vdata%lm + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + + iroot = 0 + ip = mypet + N = nx_sum + M = petCount + nsend = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) + allocate ( recvcount (petCount) ) + allocate ( displs (petCount) ) + do ip=0, M-1 + recvcount(ip+1) = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) + end do + displs(1)=0 + do i = 2, petCount + displs(i) = displs(i-1) + recvcount(i-1) + end do + + nsend_v = nsend * lm ! vertical + allocate (recvcount_v, source = recvcount * lm ) + allocate (displs_v, source = displs * lm ) + + if (mapl_am_i_root()) then + allocate ( p_rt_2d(nx_sum) ) + else + allocate ( p_rt_2d(1) ) + end if + + ! p_rt_3d (lm, nx) + if (mapl_am_i_root()) then + allocate ( p_rt_3d(lm, nx_sum) ) + allocate ( p_rt_3d_aux(nx_sum, lm) ) + else + allocate ( p_rt_3d(lm, 1) ) + allocate ( p_rt_3d_aux(1,lm) ) + end if + + + !__ Aux. field + ! + call MAPL_TimerOn(this%GENSTATE,"FieldCreate") + + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + field_ds_2d = ESMF_FieldCreate (this%LS_ds, name='field_2d_ds', typekind=ESMF_TYPEKIND_R4, _RC) + field_chunk_2d = ESMF_FieldCreate (this%LS_chunk, name='field_2d_chunk', typekind=ESMF_TYPEKIND_R4, _RC) + new_src_field = ESMF_FieldCreate (grid, name='new_src_field', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2,3],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + new_dst_field = ESMF_FieldCreate (this%LS_ds, name='new_dst_field', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + field_chunk_3d = ESMF_FieldCreate (this%LS_chunk, name='field_3d_chunk', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + call ESMF_FieldGet(field_ds_2d, localDE=0, farrayptr=p_ds_2d, _RC) + call ESMF_FieldGet(field_chunk_2d,localDE=0, farrayPtr=p_chunk_2d, _RC) + call ESMF_FieldGet(new_src_field, localDE=0, farrayPtr=p_src_3d, _RC) + call ESMF_FieldGet(new_dst_field, localDE=0, farrayPtr=p_dst_3d, _RC) + call ESMF_FieldGet(field_chunk_3d,localDE=0, farrayPtr=p_chunk_3d, _RC) + + call MAPL_TimerOff(this%GENSTATE,"FieldCreate") + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + !! if (mapl_am_i_root()) write(6,*) 'item%xname=', trim(item%xname) + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + select case (rank) + case(2) + call ESMF_FieldGet(src_field,localDE=0,farrayptr=p_src_2d,_RC) + call ESMF_FieldRegrid (src_field, field_ds_2d, this%regridder%route_handle, _RC) + call ESMF_FieldRedist (field_ds_2d, field_chunk_2d, this%RH, _RC ) + call MPI_gatherv ( p_chunk_2d, nsend, MPI_REAL, & + p_rt_2d, recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) + + call MAPL_TimerOn(this%GENSTATE,"put2D") + if (mapl_am_i_root()) then + call this%formatter%put_var(trim(item%xname),p_rt_2d,& + start=[1,this%obs_written],count=[this%nstation,1],_RC) + end if + call MAPL_TimerOff(this%GENSTATE,"put2D") + + case(3) + ! -- CS-> LS_ds; ds->chunk; gather + ! + call ESMF_FieldGet(src_field,localDE=0,farrayptr=qin_3d,_RC) + + call MAPL_TimerOn(this%GENSTATE,"reshape") + p_src_3d = reshape(qin_3d,shape(p_src_3d),order=[2,3,1]) + call MAPL_TimerOff(this%GENSTATE,"reshape") + + call MAPL_TimerOn(this%GENSTATE,"3d_regrid") + call ESMF_FieldRegrid (new_src_field, new_dst_field, this%regridder%route_handle, _RC) + call MAPL_TimerOff(this%GENSTATE,"3d_regrid") + + call MPI_Barrier(mpic,ierr) + _VERIFY (ierr) + call MAPL_TimerOn(this%GENSTATE,"FieldRedist") + call ESMF_FieldRedist (new_dst_field, field_chunk_3d, this%RH, _RC) + call MPI_Barrier(mpic,ierr) + _VERIFY (ierr) + call MAPL_TimerOff(this%GENSTATE,"FieldRedist") + + + call MAPL_TimerOn(this%GENSTATE,"gatherv") + if (this%level_by_level) then + ! p_chunk_3d (lm, nx) + allocate (p_dst_t, source = reshape(p_chunk_3d, [size(p_chunk_3d,2),size(p_chunk_3d,1)], order=[2,1])) + do k = 1, lm + call MPI_gatherv ( p_dst_t(1,k), nsend, MPI_REAL, & + p_rt_3d_aux(1,k), recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) + _VERIFY (ierr) + end do + deallocate(p_dst_t) + p_rt_3d = reshape(p_rt_3d_aux, shape(p_rt_3d), order=[2,1]) + else + call MPI_gatherv ( p_chunk_3d, nsend_v, MPI_REAL, & + p_rt_3d, recvcount_v, displs_v, MPI_REAL,& + iroot, mpic, ierr ) + end if + call MAPL_TimerOff(this%GENSTATE,"gatherv") + + + call MAPL_TimerOn(this%GENSTATE,"put3D") + if (mapl_am_i_root()) then + nz=size(p_rt_3d,1); nx=size(p_rt_3d,2) + call this%formatter%put_var(trim(item%xname),p_rt_3d,& + start=[1,1,this%obs_written],count=[nz,nx,1],_RC) + !note: lev,station,time + end if + call MAPL_TimerOff(this%GENSTATE,"put3D") + case default + _FAIL('grid2LS regridder: rank > 3 not implemented') + end select else - _FAIL('grid2LS regridder: rank > 3 not implemented') - end if + _FAIL ('ItemType vector not supported') + endif + + call iter%next() end do - deallocate (fieldNameList) + + + call MAPL_TimerOn(this%GENSTATE,"FieldDestroy") + call ESMF_FieldDestroy(field_ds_2d, noGarbage=.true., _RC) + call ESMF_FieldDestroy(field_chunk_2d, noGarbage=.true., _RC) + call ESMF_FieldDestroy(field_chunk_3d, noGarbage=.true., _RC) + call ESMF_FieldDestroy(new_dst_field, noGarbage=.true., _RC) + call ESMF_FieldDestroy(new_src_field, noGarbage=.true., _RC) + call MAPL_TimerOff(this%GENSTATE,"FieldDestroy") + _RETURN(_SUCCESS) end subroutine append_file @@ -413,14 +708,14 @@ subroutine create_file_handle(this,filename,rc) this%ofile = trim(filename) v = this%time_info%define_time_variable(_RC) - call this%fmd%modify_variable('time',v,_RC) + call this%metadata%modify_variable('time',v,_RC) this%obs_written = 0 if (.not. mapl_am_I_root()) then _RETURN(_SUCCESS) end if call this%formatter%create(trim(filename),_RC) - call this%formatter%write(this%fmd,_RC) + call this%formatter%write(this%metadata,_RC) call this%formatter%put_var('longitude',this%lons,_RC) call this%formatter%put_var('latitude',this%lats,_RC) call this%formatter%put_var('station_id',this%station_id,_RC) @@ -491,7 +786,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) integer lastspace,since_pos integer year,month,day,hour,min,sec - var => this%fmd%get_variable('time',_RC) + var => this%metadata%get_variable('time',_RC) attr => var%get_attribute('units') ptimeUnits => attr%get_value() select type(pTimeUnits) @@ -570,6 +865,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) _RETURN(_SUCCESS) end subroutine get_file_start_time + ! TODO: delete and use system utilities when available Subroutine count_substring (str, t, ncount, rc) character (len=*), intent(in) :: str @@ -616,7 +912,6 @@ subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) endif _ASSERT (ios==0, 'read error') - k=index(line(j+1:), '.') if (k > 0) then read(line(j+1:), *, iostat=ios) lat diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index 18f78e4e2d55..49c2eff96b38 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -7,6 +7,8 @@ module HistoryTrajectoryMod use LocStreamFactoryMod use MAPL_LocstreamRegridderMod use MAPL_ObsUtilMod + use MAPL_GenericMod, only : MAPL_MetaComp + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -26,6 +28,7 @@ module HistoryTrajectoryMod real(kind=REAL64), allocatable :: times_R8(:) integer, allocatable :: obstype_id(:) integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file + type(MAPL_MetaComp), pointer :: GENSTATE type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle @@ -70,7 +73,7 @@ module HistoryTrajectoryMod integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index logical :: active ! case: when no obs. exist - logical :: level_by_level = .true. + logical :: level_by_level = .false. ! note ! for MPI_GATHERV of 3D data in procedure :: append_file ! we have choice LEVEL_BY_LEVEL or ALL_AT_ONCE (timing in sec below for extdata) @@ -97,11 +100,12 @@ module HistoryTrajectoryMod interface - module function HistoryTrajectory_from_config(config,string,clock,rc) result(traj) + module function HistoryTrajectory_from_config(config,string,clock,GENSTATE,rc) result(traj) type(HistoryTrajectory) :: traj type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: string type(ESMF_Clock), intent(in) :: clock + type(MAPL_MetaComp), pointer, intent(in), optional :: GENSTATE integer, optional, intent(out) :: rc end function HistoryTrajectory_from_config diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 12c2c5060e69..1ca959172e5c 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -43,7 +43,7 @@ character(len=ESMF_MAXSTR), allocatable :: word(:) integer :: nobs, head, jvar logical :: tend - integer :: i, j, k, M + integer :: i, j, k, k2, M integer :: count, idx integer :: unitr, unitw type(GriddedIOitem) :: item @@ -51,6 +51,7 @@ traj%clock=clock + if (present(GENSTATE)) traj%GENSTATE => GENSTATE call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(string)//'Epoch:', default=0, _RC) _ASSERT(time_integer /= 0, 'Epoch value in config wrong') @@ -235,13 +236,22 @@ do i=1, traj%nobs_type call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & trim(traj%obs(i)%input_template)) - j=index(traj%obs(i)%input_template , '%') k=index(traj%obs(i)%input_template , '/', back=.true.) - _ASSERT(j>0, '% is not found, template is wrong') - traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) + j=index(traj%obs(i)%input_template(k+1:), '%') + if (j>0) then + ! normal case: geos_atmosphere/aircraft.%y4%m2%d2T%h2%n2%S2Z.nc4 + traj%obs(i)%name = traj%obs(i)%input_template(k+1:k+j-1) + else + ! different case: Y%y4/M%m2/.../this.nc or ./this + k2=index(traj%obs(i)%input_template(k+1:), '.') + if (k2>0) then + traj%obs(i)%name = traj%obs(i)%input_template(k+1:k+k2) + else + traj%obs(i)%name = trim(traj%obs(i)%input_template(k+1:)) + end if + end if end do - _RETURN(_SUCCESS) 105 format (1x,a,2x,a) @@ -1096,7 +1106,6 @@ if (nx>0) then do ig = 1, this%obs(k)%ngeoval if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - call lgr%debug('%a %a', 'append:2d inner put_var item%xname', trim(item%xname)) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & start=[is],count=[nx]) end if @@ -1164,7 +1173,6 @@ if (nx>0) then do ig = 1, this%obs(k)%ngeoval if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - call lgr%debug('%a %a', 'append:3d inner put_var item%xname', trim(item%xname)) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) end if diff --git a/griddedio/FieldBundleRead.F90 b/griddedio/FieldBundleRead.F90 index 220058566215..fba7adb6c341 100644 --- a/griddedio/FieldBundleRead.F90 +++ b/griddedio/FieldBundleRead.F90 @@ -21,6 +21,7 @@ module MAPL_ESMFFieldBundleRead use MAPL_SimpleAlarm use MAPL_StringTemplate use gFTL_StringVector + use MAPL_RegridMethods use, intrinsic :: iso_fortran_env, only: REAL32 implicit none private @@ -152,7 +153,7 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ end subroutine MAPL_create_bundle_from_metdata_id - subroutine MAPL_read_bundle(bundle,file_tmpl,time,only_vars,regrid_method,noread,file_override,rc) + subroutine MAPL_read_bundle(bundle,file_tmpl,time,only_vars,regrid_method,noread,file_override,file_weights,rc) type(ESMF_FieldBundle), intent(inout) :: bundle character(len=*), intent(in) :: file_tmpl type(ESMF_Time), intent(in) :: time @@ -160,10 +161,11 @@ subroutine MAPL_read_bundle(bundle,file_tmpl,time,only_vars,regrid_method,noread integer, optional, intent(in) :: regrid_method logical, optional, intent(in) :: noread character(len=*), optional, intent(in) :: file_override + logical, optional, intent(in) :: file_weights integer, optional, intent(out) :: rc integer :: status - integer :: num_fields, metadata_id, collection_id, time_index, i + integer :: num_fields, metadata_id, collection_id, time_index, i, regrid_hints type(MAPL_GriddedIO) :: cfio character(len=ESMF_MAXPATHLEN) :: file_name type(MAPLDataCollection), pointer :: collection => null() @@ -181,7 +183,7 @@ subroutine MAPL_read_bundle(bundle,file_tmpl,time,only_vars,regrid_method,noread metadata_id = MAPL_DataAddCollection(trim(file_tmpl)) collection => DataCollections%at(metadata_id) if (present(file_override)) file_name = file_override - + metadata => collection%find(trim(file_name), _RC) call metadata%get_time_info(timeVector=time_series,rc=status) _VERIFY(status) @@ -221,6 +223,13 @@ subroutine MAPL_read_bundle(bundle,file_tmpl,time,only_vars,regrid_method,noread cfio=MAPL_GriddedIO(output_bundle=bundle,metadata_collection_id=metadata_id,read_collection_id=collection_id,items=items) call cfio%set_param(regrid_method=regrid_method) + if (present(file_weights)) then + if (file_weights) then + regrid_hints = 0 + regrid_hints = IOR(regrid_hints,REGRID_HINT_FILE_WEIGHTS) + call cfio%set_param(regrid_hints=regrid_hints) + end if + end if call cfio%request_data_from_file(trim(file_name),timeindex=time_index,rc=status) _VERIFY(status) call i_clients%done_collective_prefetch() diff --git a/pfio/BaseThread.F90 b/pfio/BaseThread.F90 index d5eb16e9c987..32dc7dc18c8b 100644 --- a/pfio/BaseThread.F90 +++ b/pfio/BaseThread.F90 @@ -29,6 +29,7 @@ module pFIO_BaseThreadMod procedure :: clear_RequestHandle procedure :: get_RequestHandle procedure :: insert_RequestHandle + procedure :: isEmpty_RequestHandle end type BaseThread contains @@ -66,6 +67,17 @@ function get_RequestHandle(this,request_id, rc) result(rh_ptr) _RETURN(_SUCCESS) end function get_RequestHandle + function isEmpty_RequestHandle(this, rc) result(empty) + class (BaseThread), target, intent(in) :: this + integer, optional, intent(out) :: rc + logical :: empty + type (IntegerRequestMapIterator) :: iter + + iter = this%open_requests%begin() + empty = (iter == this%open_requests%end()) + _RETURN(_SUCCESS) + end function isEmpty_RequestHandle + subroutine insert_RequestHandle(this,request_id, handle, rc) class (BaseThread), target, intent(inout) :: this integer, intent(in) :: request_id diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index f85647b4a163..15390fb324e5 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -13,6 +13,7 @@ set (srcs pFIO_Constants.F90 UnlimitedEntity.F90 Attribute.F90 + IntArray.F90 Variable.F90 CoordinateVariable.F90 StringVariableMap.F90 diff --git a/pfio/ClientThread.F90 b/pfio/ClientThread.F90 index 40b778c633d7..146c0f9b4745 100644 --- a/pfio/ClientThread.F90 +++ b/pfio/ClientThread.F90 @@ -410,6 +410,10 @@ subroutine done_prefetch(this, rc) class(AbstractSocket),pointer :: connection integer :: status + if (this%isEmpty_RequestHandle()) then + _RETURN(_SUCCESS) + endif + connection=>this%get_connection() call connection%send(PrefetchDoneMessage(),_RC) _RETURN(_SUCCESS) @@ -420,6 +424,10 @@ subroutine done_collective_prefetch(this, rc) integer, optional, intent(out) :: rc class(AbstractSocket),pointer :: connection integer :: status + + if (this%isEmpty_RequestHandle()) then + _RETURN(_SUCCESS) + endif connection=>this%get_connection() call connection%send(CollectivePrefetchDoneMessage(),_RC) @@ -432,6 +440,10 @@ subroutine done_stage(this, rc) class(AbstractSocket),pointer :: connection integer :: status + if (this%isEmpty_RequestHandle()) then + _RETURN(_SUCCESS) + endif + connection=>this%get_connection() call connection%send(StageDoneMessage(),_RC) _RETURN(_SUCCESS) @@ -443,6 +455,10 @@ subroutine done_collective_stage(this, rc) class(AbstractSocket),pointer :: connection integer :: status + if (this%isEmpty_RequestHandle()) then + _RETURN(_SUCCESS) + endif + connection=>this%get_connection() call connection%send(CollectiveStageDoneMessage(),_RC) _RETURN(_SUCCESS) diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index ec6f5e7fb1dd..d9c42ba162e7 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -26,6 +26,7 @@ module pFIO_ForwardDataAndMessageMod procedure :: add_data_message procedure :: serialize procedure :: deserialize + procedure :: destroy end type ForwardDataAndMessage interface ForwardDataAndMessage @@ -104,5 +105,19 @@ subroutine add_data_message(this, msg, i_ptr, rc) _RETURN(_SUCCESS) end subroutine + subroutine destroy(this, rc) + class (ForwardDataAndMessage), intent(inout) :: this + integer, optional, intent(out) :: rc + type (MessageVectorIterator) :: iter + + if (allocated(this%idata)) deallocate(this%idata) + iter = this%msg_vec%begin() + do while (iter /= this%msg_vec%end()) + call this%msg_vec%erase(iter) + iter = this%msg_vec%begin() + enddo + _RETURN(_SUCCESS) + end subroutine + end module pFIO_ForwardDataAndMessageMod diff --git a/pfio/IntArray.F90 b/pfio/IntArray.F90 new file mode 100644 index 000000000000..7e3b76337e32 --- /dev/null +++ b/pfio/IntArray.F90 @@ -0,0 +1,102 @@ +!------------------------------------------------------------------------------ +! Global Modeling and Assimilation Office (GMAO) ! +! Goddard Earth Observing System (GEOS) ! +! MAPL Component ! +!------------------------------------------------------------------------------ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +!> +!### MODULE: `pFIO_IntArrayMod` +! +! Author: GMAO SI-Team +! +! The module `pFIO_IntArrayMod` is a simple integer 1d attribute to avoid ifort bug ( until 2024.0.0) +! +module pFIO_IntArrayMod + + use pFIO_ConstantsMod + use pFIO_UtilitiesMod + use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: INT32, INT64 + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + + implicit none + private + + public :: IntArray + type :: IntArray + private + integer, pointer :: values(:) + contains + procedure :: get_values + procedure :: destroy + end type IntArray + + interface IntArray + module procedure new_IntArray_1d !! vector constructor + module procedure new_IntArray_1d_size !! just size + end interface IntArray + +contains + + function new_IntArray_1d(values, rc) result(attr) + type (IntArray) :: attr + integer, intent(in) :: values(:) + integer, optional, intent(out) :: rc + + allocate(attr%values, source=values) + + _RETURN(_SUCCESS) + end function new_IntArray_1d + + function new_IntArray_1d_size(size, rc) result(attr) + type (IntArray) :: attr + integer(kind=INT64), intent(in) :: size + integer, optional, intent(out) :: rc + + allocate(attr%values(size)) + + _RETURN(_SUCCESS) + end function new_IntArray_1d_size + + subroutine destroy(this, rc) + class (IntArray), intent(inout) :: this + integer, optional, intent(out) :: rc + if(associated(this%values)) deallocate(this%values) + _RETURN(_SUCCESS) + end subroutine destroy + + function get_values(this, rc) result(values) + class (IntArray), target, intent(in) :: this + integer, optional, intent(out) :: rc + integer, pointer :: values(:) + + if (associated(this%values)) then + values => this%values + else + values => null() + end if + _RETURN(_SUCCESS) + end function get_values + +end module pFIO_IntArrayMod + + +! The following module defines an FTL map (associative array) with keys that are deferred +! length strings and values that are IntArrays. + +module pFIO_StringIntArrayMapMod + use pFIO_IntArrayMod + +#include "types/key_deferredLengthString.inc" +#define _value type (IntArray) +#define _value_equal_defined + +#define _map StringIntArrayMap +#define _iterator StringIntArrayMapIterator + +#define _alt +#include "templates/map.inc" + +end module pFIO_StringIntArrayMapMod diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 71278ddd922b..77da6fb43348 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -35,9 +35,8 @@ module pFIO_MultiGroupServerMod use pFIO_HistoryCollectionVectorMod use pFIO_HistoryCollectionVectorUtilMod use pFIO_BaseServerMod - use pFIO_AttributeMod - use pFIO_StringAttributeMapMod - use pFIO_StringAttributeMapUtilMod + use pFIO_IntArrayMod + use pFIO_StringIntArrayMapMod use MAPL_SplitCommunicatorMod use MAPL_SimpleCommSplitterMod use pFIO_MpiSocketMod @@ -312,7 +311,7 @@ subroutine receive_output_data(this, rc) class (MultiGroupServer),target, intent(inout) :: this integer, optional, intent(out) :: rc - integer :: i, client_num + integer :: i, client_num, status class (ServerThread),pointer :: thread_ptr type (MessageVectorIterator) :: iter @@ -418,9 +417,9 @@ subroutine receive_output_data(this, rc) endif call Mpi_Bcast( back_local_rank, 1, MPI_INTEGER, 0, this%front_comm, ierror) - if (allocated(this%buffers(back_local_rank+1)%buffer)) call MPI_Wait(this%buffers(back_local_rank+1)%request, MPI_STAT, ierror) call f_d_ms(collection_counter)%serialize(this%buffers(back_local_rank+1)%buffer) + call f_d_ms(collection_counter)%destroy(_RC) msg_size= size(this%buffers(back_local_rank+1)%buffer) call Mpi_send(msg_size,1, MPI_INTEGER, this%back_ranks(back_local_rank+1), & this%back_ranks(back_local_rank+1), this%server_comm, ierror) @@ -625,15 +624,15 @@ subroutine start_back_writers(rc) integer, pointer :: g_4d(:,:,:,:), l_4d(:,:,:,:), g_5d(:,:,:,:,:), l_5d(:,:,:,:,:) integer :: d_rank, request_id integer(kind=INT64) :: msize_word, s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 - type (StringAttributeMap), target :: vars_map - type (StringAttributeMapIterator) :: var_iter + type (StringIntArrayMap), target :: vars_map + type (StringIntArrayMapIterator) :: var_iter type (IntegerMessageMap), target :: msg_map type (IntegerMessageMapIterator) :: msg_iter - class (*), pointer :: x_ptr(:) + integer, pointer :: x_ptr(:) integer , allocatable :: buffer_v(:) - type (Attribute), pointer :: attr_ptr - type (Attribute) :: attr_tmp + type (IntArray), pointer :: array_ptr + type (IntArray) :: array_tmp type (c_ptr) :: address type (ForwardDataAndMessage), target :: f_d_m type (FileMetaData) :: fmd @@ -644,7 +643,6 @@ subroutine start_back_writers(rc) real(kind=REAL64) :: file_size, speed class(Logger), pointer :: lgr - back_local_rank = this%rank thread_ptr => this%threads%at(1) file_timer = AdvancedMeter(MpiTimerGauge()) @@ -682,7 +680,7 @@ subroutine start_back_writers(rc) enddo ! nfront ! re-org data - vars_map = StringAttributeMap() + vars_map = StringIntArrayMap() msg_map = IntegerMessageMap() file_size = 0. @@ -699,23 +697,18 @@ subroutine start_back_writers(rc) msg => f_d_m%msg_vec%at(j) select type (q=>msg) type is (CollectiveStageDataMessage) + msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) var_iter = vars_map%find(i_to_string(q%request_id)) if (var_iter == vars_map%end()) then msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) - allocate(buffer_v(msize_word), source = -1) - attr_tmp = Attribute(buffer_v) - deallocate(buffer_v) - call vars_map%insert(i_to_string(q%request_id),attr_tmp) - call attr_tmp%destroy() + array_tmp = IntArray(msize_word) + call vars_map%insert(i_to_string(q%request_id),array_tmp) var_iter = vars_map%find(i_to_string(q%request_id)) call msg_map%insert(q%request_id, q) endif - attr_ptr => var_iter%value() - x_ptr => attr_ptr%get_values() - select type (ptr=>x_ptr) - type is (integer(INT32)) - address = c_loc(ptr(1)) - end select + array_ptr => var_iter%value() + x_ptr => array_ptr%get_values() + address = c_loc(x_ptr(1)) d_rank = size(q%global_count) ! first dimension increases q%global_count(1) = word_size(q%type_kind)*q%global_count(1) @@ -818,6 +811,7 @@ subroutine start_back_writers(rc) enddo ! nfront call FileMetadata_deserialize(buffer_fmd, fmd) + deallocate (buffer_fmd) call thread_ptr%hist_collections%push_back(HistoryCollection(fmd)) @@ -825,14 +819,10 @@ subroutine start_back_writers(rc) do while (msg_iter /= msg_map%end()) request_id = msg_iter%key() msg =>msg_iter%value() - var_iter = vars_map%find(i_to_string(request_id)) - attr_ptr =>var_iter%value() - x_ptr => attr_ptr%get_values() - select type (ptr=>x_ptr) - type is (integer(INT32)) - address = c_loc(ptr(1)) - end select + array_ptr =>var_iter%value() + x_ptr => array_ptr%get_values() + address = c_loc(x_ptr(1)) select type (q=>msg) class is (AbstractDataMessage) filename =q%file_name @@ -841,7 +831,15 @@ subroutine start_back_writers(rc) call file_timer%stop() end select call msg_iter%next() + call array_ptr%destroy(_RC) + call vars_map%erase(var_iter) enddo + msg_iter = msg_map%begin() + do while (msg_iter /= msg_map%end()) + call msg_map%erase(msg_iter) + msg_iter = msg_map%begin() + enddo + call thread_ptr%clear_hist_collections() call thread_ptr%hist_collections%clear() @@ -852,7 +850,6 @@ subroutine start_back_writers(rc) call lgr%info(" Writing time: %f9.3 s, speed: %f9.3 MB/s, size: %f9.3 MB, at server node: %i0~:%i0~, file: %a", time, speed, file_size, this%node_rank, this%innode_rank, filename) call file_timer%reset() - deallocate (buffer_fmd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! telling captain it is idle by sending its own rank