diff --git a/.circleci/config.yml b/.circleci/config.yml index 98b455ca9020..0a1c854571f0 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -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: diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 0e3987557aa7..226b68f73357 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -3,6 +3,7 @@ - [ ] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to change) - [ ] Trivial change (affects only documentation or cleanup) +- [ ] Refactor (no functional changes, no api changes) ## Checklist - [ ] Tested this change with a run of GEOSgcm 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 cfea0235e181..bbf0a9e62f6d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,12 +17,48 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated -## [2.46.3] - 2024-08-16 +## [2.47.2] - 2024-08-16 ### Fixed - Fix bug in supporting externally initialized MPI +## [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 @@ -42,9 +78,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Update `FindESMF.cmake` to match that in ESMF 8.6.1 - -### Changed - +- Add timer to the sampler code - Set required version of ESMF to 8.6.1 - Update `components.yaml` - ESMA_cmake v3.45.0 diff --git a/CMakeLists.txt b/CMakeLists.txt index 2a0ecb3b109a..febab17e3ed3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.46.3 + VERSION 2.47.2 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui 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/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index b5da6efa79d2..1b96fad92ae8 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -941,11 +941,16 @@ subroutine fglob(search_name, filename, rc) ! give the last name character(kind=C_CHAR, len=:), allocatable :: c_search_name character(kind=C_CHAR, len=512) :: c_filename - integer slen + 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 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/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/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 8db5c310f58b..bf46f2c95c5d 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.45.1 + tag: v3.46.0 develop: develop ecbuild: 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/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 4185dc8e1573..1ca959172e5c 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -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') @@ -1105,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 @@ -1173,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/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)