diff --git a/.circleci/config.yml b/.circleci/config.yml index c1d9deaf44b9..b4dee0c83db0 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -24,9 +24,8 @@ orbs: ci: geos-esm/circleci-tools@2 workflows: - build-and-test: + build-and-test-MAPL: jobs: - # Builds MAPL in a "default" way - Intel - ci/build: name: build-and-test-MAPL-on-<< matrix.compiler >>-using-<< matrix.cmake_generator >> @@ -35,7 +34,7 @@ workflows: matrix: parameters: compiler: [ifort] - cmake_generator: ['Unix Makefiles'] + cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false @@ -61,7 +60,7 @@ workflows: matrix: parameters: compiler: [gfortran] - cmake_generator: ['Unix Makefiles'] + cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false @@ -86,29 +85,37 @@ workflows: run_unit_tests: true ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" - # Build GEOSgcm -- ifort - - ci/build: - name: build-GEOSgcm-on-<< matrix.compiler >> + # Run MAPL Tutorials + - ci/run_mapl_tutorial: + name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: + #compiler: [gfortran, ifort] compiler: [ifort] + tutorial_name: + - hello_world + - parent_no_children + - parent_one_child_import_via_extdata + - parent_one_child_no_imports + - parent_two_siblings_connect_import_export + # We will only run the tutorials with GNU make. No need to double up + # as Ninja is a build test only + requires: + - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version - repo: GEOSgcm - checkout_fixture: true - mepodevelop: true - checkout_mapl_branch: true - persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - # Build GEOSgcm -- GCC + build-and-run-GEOSgcm: + jobs: + # Build GEOSgcm -- ifort - ci/build: name: build-GEOSgcm-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - compiler: [gfortran] + compiler: [ifort] baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true @@ -116,35 +123,20 @@ workflows: checkout_mapl_branch: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - # Build GEOSldas on ifort - - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false - checkout_fixture: true - fixture_branch: develop - checkout_mapl_branch: true - - # Build GEOSldas on gfortran + # Build GEOSgcm -- GCC - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> + name: build-GEOSgcm-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: compiler: [gfortran] baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false + repo: GEOSgcm checkout_fixture: true - fixture_branch: develop + mepodevelop: true checkout_mapl_branch: true + persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day # Run GCM (1 hour, no ExtData) - ci/run_gcm: @@ -176,26 +168,37 @@ workflows: gcm_ocean_type: MOM6 change_layout: false - # Run MAPL Tutorials - - ci/run_mapl_tutorial: - name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> + build-GEOSldas: + jobs: + # Build GEOSldas on ifort + - ci/build: + name: build-GEOSldas-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - #compiler: [gfortran, ifort] compiler: [ifort] - tutorial_name: - - hello_world - - parent_no_children - - parent_one_child_import_via_extdata - - parent_one_child_no_imports - - parent_two_siblings_connect_import_export - # We will only run the tutorials with GNU make. No need to double up - # as Ninja is a build test only - requires: - - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version + repo: GEOSldas + mepodevelop: false + checkout_fixture: true + fixture_branch: develop + checkout_mapl_branch: true + + # Build GEOSldas on gfortran + - ci/build: + name: build-GEOSldas-on-<< matrix.compiler >> + context: + - docker-hub-creds + matrix: + parameters: + compiler: [gfortran] + baselibs_version: *baselibs_version + repo: GEOSldas + mepodevelop: false + checkout_fixture: true + fixture_branch: develop + checkout_mapl_branch: true build-GEOSadas: jobs: @@ -250,7 +253,7 @@ workflows: baselibs_version: *baselibs_version container_name: mapl mpi_name: openmpi - mpi_version: 4.1.4 + mpi_version: 5.0.0 compiler_name: gcc compiler_version: 12.1.0 image_name: geos-env-mkl diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 8d77a47ab3b9..4a360a7d2b51 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.17.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.17.0-openmpi_5.0.0-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -30,7 +30,7 @@ jobs: OMPI_MCA_btl_vader_single_copy_mechanism: none steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.12.0 + uses: styfle/cancel-workflow-action@0.12.1 with: access_token: ${{ github.token }} - name: Checkout @@ -86,7 +86,7 @@ jobs: #password: ${{ secrets.DOCKERHUB_TOKEN }} steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.12.0 + uses: styfle/cancel-workflow-action@0.12.1 with: access_token: ${{ github.token }} - name: Checkout diff --git a/.gitignore b/.gitignore index 1d39e86a6c17..5e844f143a4a 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,10 @@ *.py.bak CMakeUserPresets.json +# Ignore possible symlinked build and install directories +build-* +install-* + *.swp *.swo .DS_Store diff --git a/Apps/CMakeLists.txt b/Apps/CMakeLists.txt index 41cd7462a4a7..7c3e9507c814 100644 --- a/Apps/CMakeLists.txt +++ b/Apps/CMakeLists.txt @@ -24,7 +24,7 @@ install( DESTINATION bin/forcing_converter) ecbuild_add_executable (TARGET Regrid_Util.x SOURCES Regrid_Util.F90) -target_link_libraries (Regrid_Util.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (Regrid_Util.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (Regrid_Util.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") @@ -32,7 +32,7 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") endif () ecbuild_add_executable (TARGET time_ave_util.x SOURCES time_ave_util.F90) -target_link_libraries (time_ave_util.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (time_ave_util.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (time_ave_util.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") @@ -40,7 +40,7 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") endif () ecbuild_add_executable (TARGET Comp_Testing_Driver.x SOURCES Comp_Testing_Driver.F90) -target_link_libraries (Comp_Testing_Driver.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (Comp_Testing_Driver.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (Comp_Testing_Driver.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index 7a247d05c615..5ce9f17d2d44 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -338,7 +338,7 @@ Program Regrid_Util subroutine main() - type(regrid_support) :: support + type(regrid_support), target :: support type(ESMF_VM) :: vm ! ESMF Virtual Machine diff --git a/CHANGELOG.md b/CHANGELOG.md index 7257eacacba1..6dcd08ebfdcf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,54 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.44.0] - 2024-02-08 + +### Added + +- Added nf90 interface to read and write 1d string +- Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) +- Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX +- Modify swath sampler to handle two Epoch swath grids +- Handle regrid accumulate for time step (1 sec) during which no obs exists +- Use IntState%stampoffset(n) to adjust filenames for an epoch time +- parse "GOCART::CO2" from 'geovals_fields' entry in PLATFORM +- Add call MAPL_InitializeShmem to ExtDataDriverGridComp.F90 +- Read swath data on root, call MAPL_CommsBcast [which sends data to Shmem (when Shmem initialized) or to MAPL_comm otherwise]. This approach avoids race in reading nc files [e.g. 37 files for 3 hr swath data] +- Added memory utility, MAPL_MemReport that can be used in any code linking MAPL +- Added capability in XY grid factory to add a mask to the grid any points are missing needed for geostationary input data +- Added capability in the MAPL ESMF regridding wrapper to apply a destination mask if the destination grid contains a mask +- Added `INSTALL.md` file to provide instructions on how to install MAPL + +### Changed + +- Updated ESMF required version to 8.6.0 +- Allocate gridded fields to use the pinflag option needed for the Single System Image (SSI) capability. +- Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. +- Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. +- Updated CI to use Open MPI 5.0.0 for GNU +- Enable Ninja for CI builds of MAPL +- Removed use of `ESMF_HAS_ACHAR_BUG` CMake option and code use in `MAPL_Config.F90`. Testing has shown that with ESMF 8.6 (which is + now required), NAG no longer needs this workaround. +- Refactor the CircleCI workflows for more flexibility +- Fix field utils issue - add npes argument to test subroutine decorators. +- Change MAPL CMake to use `ESMF::ESMF` target instead of `esmf` or `ESMF` as the imported target name + - Updated `FindESMF.cmake` to match that of ESMF `develop` as of commit `da8f410`. This will be in ESMF 8.6.1+ + - Requires ESMA_cmake 3.40.0 or later as this adds the `ESMF::ESMF` target ALIAS for Baselibs and non-Baselibs builds +- Changed `CMakePresets.json` + - Updated to version 7 and required CMake 3.27.0 (the minimum version that supports CMakePresets.json v7) + - Changed build style on NCCS machines to by default put build and install directories in a user-specified directory so as not to + pollute swdev + +### Fixed + +- Restore missing submodule interfaces +- Explictly `use` some `iso_c_binding` types previously pulled in through ESMF. This is fixed in future ESMF versions (8.7+) and so + we anticipate this here +- Add explicit `Fortran_MODULE_DIRECTORY` to `CMakeLists.txt` in benchmarks to avoid race condition in Ninja builds +- Add check to make sure ESMF was not built as `mpiuni` +- Fixed failing tests for `field_utils`. +- Various fixes for NVHPC work + ## [2.43.2] - 2024-02-06 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 191bda534427..5e2df2da13e6 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.43.2 + VERSION 2.44.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui @@ -147,28 +147,29 @@ if (NOT Baselibs_FOUND) add_definitions(-DH5_HAVE_PARALLEL) endif() - if (NOT TARGET esmf) - find_package(ESMF 8.5.0 MODULE REQUIRED) + if (NOT TARGET ESMF::ESMF) + find_package(ESMF 8.6.0 MODULE REQUIRED) # ESMF as used in MAPL requires MPI # NOTE: This looks odd because some versions of FindESMF.cmake out in the # world provide an "esmf" target while others provide "ESMF". So we # need this ugliness to support both. - if (TARGET esmf) - target_link_libraries(esmf INTERFACE MPI::MPI_Fortran) + if (TARGET ESMF::ESMF) + target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) else() - target_link_libraries(ESMF INTERFACE MPI::MPI_Fortran) + target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) # MAPL and GEOS use lowercase target due to historical reasons but # the latest FindESMF.cmake file from ESMF produces an ESMF target. - add_library(esmf ALIAS ESMF) + add_library(ESMF::ESMF ALIAS ESMF) + add_library(ESMF::ESMF ALIAS esmf) endif() endif () else () # This is an ESMF version test when using Baselibs which doesn't use the # same find_package internally in ESMA_cmake as used above (with a version # number) so this lets us at least trap use of old Baselibs here. - if (ESMF_VERSION VERSION_LESS 8.5.0) - message(FATAL_ERROR "ESMF must be at least 8.5.0") + if (ESMF_VERSION VERSION_LESS 8.6.0) + message(FATAL_ERROR "ESMF must be at least 8.6.0") endif () endif () diff --git a/CMakePresets.json b/CMakePresets.json index 77d1727caecd..60c99f0d9d00 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -1,22 +1,14 @@ { - "version": 3, + "version": 7, "cmakeMinimumRequired": { "major": 3, - "minor": 21, + "minor": 27, "patch": 0 }, + "include": [ + "presets/CMake$penv{CMAKE_PRESET_NAME}Presets.json" + ], "configurePresets": [ - { - "name": "base-configure", - "hidden": true, - "displayName": "Base Configure Settings", - "description": "Sets build and install directories", - "binaryDir": "${sourceDir}/build-${presetName}", - "cacheVariables": { - "BASEDIR": "$env{BASEDIR}", - "CMAKE_INSTALL_PREFIX": "${sourceDir}/install-${presetName}" - } - }, { "name": "base-gnu", "hidden": true, diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 000000000000..16696eec4d44 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,158 @@ +# MAPL Installation Instructions + +## Dependent Libraries + +### Compilers + +MAPL requires a Fortran 2003 compliant compiler. It is currently tested and +supported with: + +- Intel Fortran Classic `ifort` 2021.6.0 +- GCC 12.3.0 +- NAG Fortran 7.1.43 + +Note that at present MAPL does not fully support GCC 13, Intel Fortran Classic +2021.10.0+, Intel LLVM `ifx`, or NVHPC. Efforts are underway to support these. + +### MPI + +MAPL requires MPI and has been tested to run with: + +- Open MPI +- Intel MPI +- MPICH 4 (only MAPL 2.41 and higher) +- MVAPICH2 + +### Libraries + +MAPL currently depends on many libraries for full use of its capabilities. These include: + +- [ESMF](https://github.com/esmf-org/esmf) + - [netCDF-Fortran](https://github.com/Unidata/netcdf-fortran) + - [netCDF-C](https://github.com/Unidata/netcdf-c) + - [HDF5](https://github.com/HDFGroup/hdf5) +- [GFE](https://github.com/Goddard-Fortran-Ecosystem/GFE) + - [gFTL](https://github.com/Goddard-Fortran-Ecosystem/gFTL) + - [gFTL-shared](https://github.com/Goddard-Fortran-Ecosystem/gFTL-shared) + - [fArgParse](https://github.com/Goddard-Fortran-Ecosystem/fArgParse) + - [pFUnit](https://github.com/Goddard-Fortran-Ecosystem/pFUnit) (for unit testing) + - [yaFyaml](https://github.com/Goddard-Fortran-Ecosystem/yaFyaml) + - [pFlogger](https://github.com/Goddard-Fortran-Ecosystem/pFlogger) + +MAPL is currently tested with the following library versions: + +| Package | Tested Version | +|:---------------|:---------------| +| HDF5 | v1.10.11 | +| netCDF-C | v4.9.2 | +| netCDF-Fortran | v4.6.1 | +| ESMF | v8.6.0 | +| GFE | v1.12.0 | + +Note that in most cases, MAPL will support *higher* versions of these libraries +(e.g., HDF5 1.14), it's just operationally we have not moved to them and fully +tested it. + + +#### ESMA Baselibs + +The above libraries are equivalent to ESMA-Baselibs v7.17.2. This is used +internally by GEOS-ESM users at the GMAO. + +## Getting MAPL + +### Obtaining MAPL from git clone + +Obtaining MAPL via a `git clone` is a bit complex due to how we handle +sub-repositories. Rather than use Git submodules or +ExternalProject/FetchContent, we use a homegrown tool called +[`mepo`](https://github.com/GEOS-ESM/mepo/) to manage them. `mepo` uses the +`components.yaml` file to know what tag of each sub-repository to clone, where +to put it, and what to name it. + +`mepo` is a fairly simple Python3 tool. All a user needs to do is clone the +`mepo` repo which provides executable `mepo` script that just needs Python3 +and PyYAML. Then you can run `mepo clone` in your MAPL clone and you'll get +three subrepos: + +- [ESMA_env](https://github.com/GEOS-ESM/ESMA_env) + - This is we use internally to control our compilers, libraries, etc. for external users it's a bit of a no-op +- [ESMA_cmake](https://github.com/GEOS-ESM/ESMA_cmake) + - This has most of our CMake controls, macros, etc. +- [ecbuild](https://github.com/GEOS-ESM/ecbuild) + - This is cloned within ESMA_cmake and gives us access to the ecbuild macros + +### Obtaining MAPL from a complete release tarfile + +A simpler way to obtain MAPL is to download a "complete" release tarfile from +the Releases page. Each release has a "complete" tarfile that has had the `mepo clone` +step run within it. This file will be named `MAPL-vX.YY.Z.COMPLETE.tar.xz` +where `X.YY.Z` is the version number of MAPL. We provide this for users that do +not want to deal with `mepo` or the sub-repositories. + +### Spack + +MAPL is also available via [spack](https://spack.io). The spack package is +maintained by GEOS-ESM and is used by external users to provide MAPL. As such, +it has many of the ideosyncracies of MAPL's clone-build-install process "baked" +into it. If you need MAPL-as-library, that could be an easier way to go by +running: +``` +spack install mapl +``` + +## Building MAPL + +Once you have all the dependent libraries, the build process should be pretty standard: + +``` +cmake -B build-dir -S . --install-prefix install-dir < -DCMAKE_Fortran_COMPILER=XXX > +cmake --build build-dir --target install -j N +``` +where `N` is the number of parallel build jobs you want to run. + +Note: If you have `FC` set in the environment, then there is no need for +`CMAKE_Fortran_COMPILER` but many environments do not provide `FC` and might +default to `gfortran` which might not be what you want. + +### Available CMake Options + +- `USE_EXTDATA2G` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL's ExtData2G library. All current GEOS-ESM projects + use ExtData2G (rather than the original ExtData) for reading external data. +- `USE_F2PY` (default: `ON`, recommended: `OFF`) + - If `ON`, will build an f2py-based interface to MAPL. This is not recommended + for general use, as f2py + CMake can be a challenge. +- `BUILD_SHARED_MAPL` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL as a shared library. If `OFF`, will build MAPL as + a static library. Note: unlike many packages, the `ON` option does not build + *both* a shared and static library. It builds *only* a shared library. +- `BUILD_WITH_FARGPARSE` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL with the `fArgParse` library. Much of MAPL's + utilities use `fArgParse` for command-line argument parsing. +- `BUILD_WITH_PFLOGGER` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL with the `pFlogger` library. This is the logging + library used by MAPL and while not required yet, it is highly recommended. +- `INSTALL_SOURCE_TARFILE` (default: `OFF`, recommended: `OFF`) + - If `ON`, will install a tarfile of the source code in the install directory. + This is useful for users that want to have the source code as an "archive" + of what was built. +- `USE_CODATA_2018_CONSTANTS` (default: `OFF`, recommended: `OFF`) + - This option enables newer CODATA constants for use in MAPL. It is not + yet defaulted to `ON` as it would change answers in codes using MAPL's + constants. + +## Running MAPL Unit Tests + +If MAPL was built with pFUnit, then the unit tests can be run with: + +``` +ctest --test-dir build-dir -j N +``` +where `N` is the number of tests you want to run in parallel. + +Note that some MAPL tests are quite expensive to run. To avoid running them, +you can instead run: +``` +ctest --test-dir build-dir -j N -LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' +``` diff --git a/MAPL/CMakeLists.txt b/MAPL/CMakeLists.txt index 694250dcc33c..edf76dfc0a20 100644 --- a/MAPL/CMakeLists.txt +++ b/MAPL/CMakeLists.txt @@ -4,7 +4,7 @@ esma_set_this() esma_add_library (${this} SRCS MAPL.F90 DEPENDENCIES MAPL.base MAPL.generic MAPL.pfio MAPL_cfio_r4 MAPL.gridcomps MAPL.orbit MAPL.griddedio MAPL.field_utils ${EXTDATA_TARGET} - esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran + ESMF::ESMF NetCDF::NetCDF_Fortran MPI::MPI_Fortran $<$:FLAP::FLAP> TYPE ${MAPL_LIBRARY_TYPE} ) diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index a7d9c3018538..01ccb4b5e8c2 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -44,7 +44,7 @@ endif () esma_add_library (${lib} SRCS ${srcs} - DEPENDENCIES esmf NetCDF::NetCDF_Fortran + DEPENDENCIES ESMF::ESMF NetCDF::NetCDF_Fortran TYPE ${LIBRARY_TYPE} ) diff --git a/README.md b/README.md index 0d35086d038f..1f8785d98d5b 100644 --- a/README.md +++ b/README.md @@ -32,6 +32,12 @@ MAPL also has a variety of other auxiliary directories: 8. **benchmarks** - miscellaneous benchmarking scripts 9. **docs** - documentation +## Installing MAPL + +Please see the [INSTALL.md](INSTALL.md) file for instructions on how to install +MAPL. This also contains information on how to install the required dependencies +including subrepositories MAPL expects. + ## Using MAPL You can find simple examples on how to use MAPL components in ESMF applications at: diff --git a/Tests/CMakeLists.txt b/Tests/CMakeLists.txt index d427e82a59c0..ebb0dcb2122d 100644 --- a/Tests/CMakeLists.txt +++ b/Tests/CMakeLists.txt @@ -11,7 +11,7 @@ set (srcs if (BUILD_WITH_FARGPARSE) ecbuild_add_executable (TARGET ExtDataDriver.x SOURCES ${srcs}) - target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(ExtDataDriver.x PRIVATE OpenMP::OpenMP_Fortran) @@ -21,14 +21,14 @@ if (BUILD_WITH_FARGPARSE) add_subdirectory(ExtData_Testing_Framework EXCLUDE_FROM_ALL) ecbuild_add_executable (TARGET pfio_MAPL_demo.x SOURCES pfio_MAPL_demo.F90) - target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(pfio_MAPL_demo.x PRIVATE OpenMP::OpenMP_Fortran) endif () set_target_properties(pfio_MAPL_demo.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) ecbuild_add_executable (TARGET MAPL_demo_fargparse.x SOURCES MAPL_demo_fargparse.F90) - target_link_libraries (MAPL_demo_fargparse.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (MAPL_demo_fargparse.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(MAPL_demo_fargparse.x PRIVATE OpenMP::OpenMP_Fortran) diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index 0873a68c4c11..d4d11b038ed4 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -144,6 +144,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) type(ExtData_DriverGridComp), pointer :: cap class(BaseProfiler), pointer :: t_p logical :: use_extdata2g + integer :: useShmem _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) @@ -176,6 +177,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigLoadFile(cap%config, cap%configFile, rc = status) _VERIFY(status) + ! CAP's MAPL MetaComp !--------------------- @@ -185,6 +187,11 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call MAPL_Set(MAPLOBJ, name = cap%name, cf = cap%config, rc = status) _VERIFY(status) + call MAPL_GetResource(MAPLOBJ, useShmem, label = 'USE_SHMEM:', default = 0, _RC) + if (useShmem /= 0) then + call MAPL_InitializeShmem (_RC) + end if + call ESMF_ConfigGetAttribute(cap%config,cap%run_fbf,label="RUN_FBF:",default=.false.) call ESMF_ConfigGetAttribute(cap%config,cap%run_hist,label="RUN_HISTORY:",default=.true.) call ESMF_ConfigGetAttribute(cap%config,cap%run_extdata,label="RUN_EXTDATA:",default=.true.) @@ -484,6 +491,8 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigDestroy(cap%config, rc = status) _VERIFY(status) + call MAPL_FinalizeSHMEM (_RC) + _RETURN(ESMF_SUCCESS) end subroutine finalize_gc diff --git a/base/Base/Base_Base.F90 b/base/Base/Base_Base.F90 index b7d2eb5e19ac..dcef19267c47 100644 --- a/base/Base/Base_Base.F90 +++ b/base/Base/Base_Base.F90 @@ -43,6 +43,7 @@ module MAPL_Base public MAPL_LatLonGridCreate ! Creates regular Lat/Lon ESMF Grids public MAPL_Nhmsf public MAPL_NSECF + public MAPL_Nsecf2 public MAPL_PackTime public MAPL_PackDateTime public MAPL_RemapBounds @@ -291,6 +292,10 @@ integer module function MAPL_nsecf(nhms) integer, intent(in) :: nhms end function MAPL_nsecf + integer module function MAPL_nsecf2 (nhhmmss,nmmdd,nymd) + integer :: nhhmmss, nmmdd, nymd + end function MAPL_nsecf2 + module subroutine MAPL_tick (nymd,nhms,ndt) integer nymd,nhms,ndt end subroutine MAPL_tick diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 151616a5ffd6..2aef8eb3ecc8 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -54,56 +54,41 @@ module subroutine MAPL_AllocateCoupling(field, rc) logical :: defaultProvided real :: default_value - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus /= ESMF_FIELDSTATUS_COMPLETE) then !ALT: if the attributeGet calls fail, this would very likely indicate ! that the field was NOT created by MAPL (or something terrible happened) ! For now we just abort - call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, _RC) + call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, _RC) + call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, _RC) + call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, _RC) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, _RC) if(defaultProvided) then - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, _RC) end if - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) if (has_ungrd) then - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, _RC) end if else if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, rc=status) - _VERIFY(STATUS) + hw=hw, _RC) end if end if @@ -146,23 +131,25 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & integer :: lb1, lb2, lb3 integer :: ub1, ub2, ub3 - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) +! SSI + character(len=ESMF_MAXSTR) :: name + type(ESMF_Pin_Flag) :: pinflag + type(ESMF_VM) :: vm + logical :: ssiSharedMemoryEnabled +! SSI + + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) _ASSERT(gridRank <= 3,' MAPL restriction - only 2 and 3d are supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, gridRank gridToFieldMap(I) = I end do ! ALT: the next allocation should have been griddedDims, ! but this compilcates the code unnecessery - allocate(haloWidth(gridRank), stat=status) - _VERIFY(STATUS) + allocate(haloWidth(gridRank), _STAT) haloWidth = (/HW,HW,0/) if(present(default_value)) then @@ -176,6 +163,15 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & szungrd = size(UNGRID) end if +! SSI + call ESMF_VMGetCurrent(vm, _RC) + + call ESMF_VMGet(vm, ssiSharedMemoryEnabledFlag=ssiSharedMemoryEnabled, _RC) + + _ASSERT(ssiSharedMemoryEnabled, 'SSI shared memory is NOT supported') + pinflag=ESMF_PIN_DE_TO_SSI_CONTIG ! requires support for SSI shared memory +! SSI + Dimensionality: select case(DIMS) ! Horizontal and vertical @@ -189,13 +185,15 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(UNGRID(1)), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & + _RC) case default _FAIL( 'unsupported rank > 1') end select @@ -203,19 +201,20 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(UNGRID(1)), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & + _RC) case default _FAIL( 'unsupported rank > 1') end select endif - _VERIFY(STATUS) ! Vertical only ! ------------- @@ -238,23 +237,27 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end select if (typekind == ESMF_KIND_R4) then - allocate(VAR_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(lb1:ub1), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=var_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=var_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - RC=status) - _VERIFY(STATUS) + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & + _RC) else - allocate(VR8_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(lb1:ub1), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=vr8_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=vr8_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - RC=status) - _VERIFY(STATUS) + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & + _RC) end if ! Horizontal only @@ -274,75 +277,66 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then RankCase2d: select case (rank) case (2) - allocate(VAR_2D(lb1:ub1, lb2:ub2), STAT=STATUS) - _VERIFY(STATUS) - VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_2D, _RC) + VAR_2D = INIT_VALUE case (3) - allocate(VAR_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) - VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & + pinflag=pinflag,_RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, _RC) + VAR_3D = INIT_VALUE case (4) - allocate(VAR_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) - _VERIFY(STATUS) - VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, _RC) + VAR_4D = INIT_VALUE case default - _FAIL( 'only up to 4D are supported') + _FAIL('only up to 4D are supported') end select RankCase2d else select case (rank) case (2) - allocate(VR8_2D(lb1:ub1, lb2:ub2), STAT=STATUS) - _VERIFY(STATUS) - VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_2D, _RC) + VR8_2D = INIT_VALUE case (3) - allocate(VR8_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) - VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, _RC) + VR8_3D = INIT_VALUE case (4) - allocate(VR8_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) - _VERIFY(STATUS) - VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, _RC) + VR8_4D = INIT_VALUE case default - _FAIL( 'only up to 4D are supported') + _FAIL('only up to 4D are supported') end select end if - _VERIFY(STATUS) ! Horz + Vert ! ----------- @@ -371,55 +365,45 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & RankCase3d: select case(rank) case (3) if (typekind == ESMF_KIND_R4) then - NULLIFY(VAR_3D) - allocate(VAR_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) - _VERIFY(STATUS) - VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, _RC) + VAR_3D = INIT_VALUE else - NULLIFY(VR8_3D) - allocate(VR8_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) - _VERIFY(STATUS) - VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, _RC) + VR8_3D = INIT_VALUE endif - _VERIFY(STATUS) case (4) if (typekind == ESMF_KIND_R4) then - NULLIFY(VAR_4D) - allocate(VAR_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) - _VERIFY(STATUS) - VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, _RC) + VAR_4D = INIT_VALUE else - NULLIFY(VR8_4D) - allocate(VR8_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) - _VERIFY(STATUS) - VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, _RC) + VR8_4D = INIT_VALUE endif - _VERIFY(STATUS) case default _RETURN(ESMF_FAILURE) @@ -434,29 +418,28 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(COUNTS(1)), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (2) - allocate(VAR_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1),UNGRID(1)), _STAT) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select @@ -464,60 +447,57 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(COUNTS(1)), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & + _RC) case (2) - allocate(VR8_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1),UNGRID(1)), _STAT) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select endif - _VERIFY(STATUS) case(MAPL_DimsTileTile) rank=2 _ASSERT(gridRank == 1, 'gridRank /= 1') if (typekind == ESMF_KIND_R4) then - allocate(VAR_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1), COUNTS(2)), _STAT) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) else - allocate(VR8_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1), COUNTS(2)), _STAT) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) endif - _VERIFY(STATUS) ! Invalid dimensionality ! ---------------------- @@ -526,12 +506,10 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & _RETURN(ESMF_FAILURE) end select Dimensionality - _VERIFY(STATUS) if (present(default_value)) then call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialDefault, RC=STATUS) - _VERIFY(STATUS) + VALUE=MAPL_InitialDefault, _RC) end if ! Clean up @@ -557,26 +535,20 @@ module subroutine MAPL_FieldF90Deallocate(field, rc) integer :: rank type(ESMF_TypeKind_Flag) :: tk - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'currently MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias call ESMF_LocalArrayGet(larray, rank=rank, typekind=tk, & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, _RC) end if _RETURN(ESMF_SUCCESS) @@ -609,32 +581,24 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -645,8 +609,7 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -682,32 +645,24 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -715,8 +670,7 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -853,10 +807,8 @@ module subroutine MAPL_MakeDecomposition(nx, ny, unusable, reduceFactor, rc) _UNUSED_DUMMY(unusable) - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) - call ESMF_VMGet(vm, petCount=pet_count, rc=status) - _VERIFY(status) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, petCount=pet_count, _RC) if (present(reduceFactor)) pet_count=pet_count/reduceFactor ! count down from sqrt(n) @@ -940,32 +892,24 @@ module subroutine MAPL_ClimInterpFac (CLOCK,I1,I2,FAC, RC) type (ESMF_TimeInterval) :: oneMonth type (ESMF_Calendar) :: cal - call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet ( CurrTime, midMonth=midMonth, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, rc=status ) - _VERIFY(STATUS) + call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, _RC ) + call ESMF_TimeGet ( CurrTime, midMonth=midMonth, _RC ) + call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, _RC ) if( CURRTIME < midMonth ) then AFTER = midMonth midMonth = midMonth - oneMonth - call ESMF_TimeGet (midMonth, midMonth=BEFORE, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=BEFORE, _RC ) else BEFORE = midMonth midMonth = midMonth + oneMonth - call ESMF_TimeGet (midMonth, midMonth=AFTER , rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=AFTER , _RC ) endif - call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, RC=STATUS) - _VERIFY(STATUS) + call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, _RC) - call ESMF_TimeGet (BEFORE, MM=I1, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet (AFTER , MM=I2, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (BEFORE, MM=I1, _RC ) + call ESMF_TimeGet (AFTER , MM=I2, _RC ) _RETURN(ESMF_SUCCESS) @@ -1181,21 +1125,17 @@ module subroutine MAPL_GetFieldTimeFromField ( FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP logical :: isPresent - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, _RC) if(.not. isPresent) then - call ESMF_TimeSet (TIME, YY=0, RC=STATUS) + call ESMF_TimeSet (TIME, YY=0, _RC) else - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) call MAPL_TimeStringGet (TIMESTAMP, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND ) - _VERIFY(STATUS) call ESMF_TimeSet (TIME, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND, & - RC=STATUS) - _VERIFY(STATUS) + _RC) end if _RETURN(ESMF_SUCCESS) @@ -1213,10 +1153,8 @@ module subroutine MAPL_SetFieldTimeFromField (FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP - call ESMF_TimeGet (TIME, timeString=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeGet (TIME, timeString=TIMESTAMP, _RC) + call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromField @@ -1233,10 +1171,8 @@ module subroutine MAPL_GetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS ) - _VERIFY(STATUS) - call MAPL_FieldGetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC ) + call MAPL_FieldGetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetFieldTimeFromState @@ -1254,10 +1190,8 @@ module subroutine MAPL_SetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldSetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC) + call MAPL_FieldSetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromState @@ -1275,142 +1209,25 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) ! are the SAME as the one in the original Field, if DoCopy flag is present ! and set to true we create a new array and copy the data, not just reference it - type(ESMF_Grid) :: grid - character(len=ESMF_MAXSTR) :: fieldName - integer, allocatable :: gridToFieldMap(:) - integer :: gridRank - integer :: fieldRank integer :: status - integer :: unGridDims character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateRename' - logical :: hasUngridDims - integer :: notGridded logical :: DoCopy_ type(ESMF_DataCopy_Flag):: datacopy - real, pointer :: var_1d(:) - real, pointer :: var_2d(:,:) - real, pointer :: var_3d(:,:,:) - real, pointer :: var_4d(:,:,:,:) - real(kind=REAL64), pointer :: vr8_1d(:) - real(kind=REAL64), pointer :: vr8_2d(:,:) - real(kind=REAL64), pointer :: vr8_3d(:,:,:) - real(kind=REAL64), pointer :: vr8_4d(:,:,:,:) - type(ESMF_TypeKind_Flag) :: tk DoCopy_ = .false. if (present(DoCopy) ) then DoCopy_ = DoCopy end if - call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & - name=fieldName, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, typekind=tk, RC=STATUS) - _VERIFY(STATUS) - - hasUngridDims = .false. - notGridded = count(gridToFieldMap==0) - unGridDims = fieldRank - gridRank + notGridded - - if (unGridDims > 0) then - hasUngridDims = .true. - endif - if (doCopy_) then datacopy = ESMF_DATACOPY_VALUE else datacopy = ESMF_DATACOPY_REFERENCE end if - f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, rc=status) - _VERIFY(STATUS) - - if (tk == ESMF_TypeKind_R4) then - select case (fieldRank) - case (1) - call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (2) - call ESMF_FieldGet(field, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=var_4d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_4D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case default - _FAIL( 'only upto 4D are supported') - end select - else if (tk == ESMF_TypeKind_R8) then - select case (fieldRank) - case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_3D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=vr8_4d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_4D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case default - _FAIL( 'only 2D and 3D are supported') - end select - else - _FAIL( 'unsupported typekind') - endif - - deallocate(gridToFieldMap) + f = ESMF_FieldCreate(field, datacopyflag=datacopy, name=NAME, _RC) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateRename @@ -1453,43 +1270,32 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) character(len=ESMF_MAXSTR) :: newName_ character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateNewgrid' - call ESMF_FieldGet(FIELD, grid=fgrid, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, grid=fgrid, _RC) - call ESMF_GridGet(fGRID, dimCount=fgridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(fgridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(fGRID, dimCount=fgridRank, _RC) + allocate(gridToFieldMap(fgridRank), _STAT) call ESMF_FieldGet(FIELD, Array=Array, name=name, & - gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + gridToFieldMap=gridToFieldMap, _RC) griddedDims = fgridRank - count(gridToFieldMap == 0) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - call ESMF_ArrayGet(array, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, rank=rank, _RC) ungriddedDims = rank - griddedDims - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, _RC) newRank = rank if (griddedDims == 1 .and. gridRank > 1) then deallocate(gridToFieldMap) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, 2 gridToFieldMap(I) = I @@ -1506,8 +1312,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) if (newRank == 2) then F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & - name=newName_, gridToFieldMap=gridToFieldMap, RC=STATUS ) - _VERIFY(STATUS) + name=newName_, gridToFieldMap=gridToFieldMap, _RC ) DIMS = MAPL_DimsHorzOnly else if (newRank == 3) then @@ -1521,7 +1326,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=[lb],ungriddedUBound=[ub],RC=STATUS ) + ungriddedLBound=[lb],ungriddedUBound=[ub],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1532,7 +1337,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & ungriddedLBound=[lbnds(griddedDims+1),lbnds(griddedDims+2)], & - ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],RC=STATUS ) + ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1544,12 +1349,10 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) ! we are saving DIMS attribute in case the FIELD did not contain one ! otherwise we will overwrite it - call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateNewgrid @@ -1581,71 +1384,54 @@ module function MAPL_FieldCreateR4(FIELD, RC) RESULT(F) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & - name=fieldName, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + name=fieldName, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'tk /= ESMF_TypeKind_R8') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) + call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, _RC) datacopy = ESMF_DATACOPY_REFERENCE select case (fieldRank) case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), stat=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_1d, _RC) + allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), _STAT) var_1d=vr8_1d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_2d, _RC) allocate(var_2d(lbound(vr8_2d,1):ubound(vr8_2d,1), & lbound(vr8_2d,2):ubound(vr8_2d,2)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_2d=vr8_2d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_3d, _RC) allocate(var_3d(lbound(vr8_3d,1):ubound(vr8_3d,1), & lbound(vr8_3d,2):ubound(vr8_3d,2), & lbound(vr8_3d,3):ubound(vr8_3d,3)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_3d=vr8_3d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateR4 @@ -1659,14 +1445,12 @@ module function MAPL_FieldCreateEmpty(NAME, GRID, RC) RESULT(FIELD) character(len=ESMF_MAXSTR),parameter :: IAm=" MAPL_FieldCreateEmpty" integer :: STATUS - FIELD = ESMF_FieldEmptyCreate(name=name, rc=status) - _VERIFY(STATUS) + FIELD = ESMF_FieldEmptyCreate(name=name, _RC) call ESMF_FieldEmptySet(FIELD, & grid=GRID, & staggerloc = ESMF_STAGGERLOC_CENTER, & - rc = status) - _VERIFY(STATUS) + _RC) _RETURN(ESMF_SUCCESS) @@ -1678,8 +1462,7 @@ module subroutine MAPL_FieldCopyAttributes(FIELD_IN, FIELD_OUT, RC) integer, optional, intent( OUT) :: RC integer :: status - call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, rc=status) - _VERIFY(status) + call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_FieldCopyAttributes @@ -1705,40 +1488,30 @@ module subroutine MAPL_FieldCopy(from, to, RC) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(from, dimCount=fieldRank, & - typekind=tk, RC=STATUS) - _VERIFY(STATUS) + typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'inconsistent typekind (should be ESMF_TypeKind_R8)') select case (fieldRank) case (1) - call ESMF_FieldGet(from, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_1d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==1, 'inconsistent fieldrank (should be 1)') - call ESMF_FieldGet(to, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_1d, _RC) var_1d = vr8_1d case (2) - call ESMF_FieldGet(from, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_2d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==2, 'inconsistent fieldRank (should be 2)') - call ESMF_FieldGet(to, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_2d, _RC) var_2d = vr8_2d case (3) - call ESMF_FieldGet(from, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_3d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==3,'inconsistent fieldRank (should be 3)') - call ESMF_FieldGet(to, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_3d, _RC) var_3d = vr8_3d case default _FAIL( 'unsupported fieldRank (> 3)') @@ -1782,24 +1555,25 @@ module subroutine MAPL_GRID_INTERIOR(GRID,I1,IN,J1,JN) integer :: deId integer :: gridRank integer, allocatable :: localDeToDeMap(:) + integer :: rc i1=-1 j1=-1 in=-1 jn=-1 - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,_RC) if (localDeCount > 0) then - allocate(localDeToDeMap(localDeCount),stat=status) - call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,rc=status) + allocate(localDeToDeMap(localDeCount),_STAT) + call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,_RC) deId=localDeToDeMap(1) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPl_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -1995,10 +1769,8 @@ module function MAPL_LatLonGridCreate (Name, vm, & if ( present(vm) ) then vm_ => vm else - allocate(vm_, stat=STATUS) - _VERIFY(STATUS) - call ESMF_VMGetCurrent(vm_, rc=STATUS) - _VERIFY(STATUS) + allocate(vm_, _STAT) + call ESMF_VMGetCurrent(vm_, _RC) end if ! Grid info via resources @@ -2008,17 +1780,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Either use supplied Config or load resource file ! ------------------------------------------------ if ( present(ConfigFile) ) then - allocate(Config_,stat=STATUS) - _VERIFY(STATUS) - Config_ = ESMF_ConfigCreate (rc=STATUS ) - _VERIFY(STATUS) - call ESMF_ConfigLoadFile (Config_, ConfigFile, rc=STATUS ) - _VERIFY(STATUS) + allocate(Config_,_STAT) + Config_ = ESMF_ConfigCreate (_RC ) + call ESMF_ConfigLoadFile (Config_, ConfigFile, _RC ) else if ( present(Config) ) then Config_ => Config else STATUS = 100 - _VERIFY(STATUS) end if ! Get relevant parameters from Config @@ -2052,7 +1820,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & else STATUS = 300 - _VERIFY(STATUS) end if @@ -2060,7 +1827,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------ if ( IM_World_ < 1 .OR. JM_World_ < 1 ) then STATUS = 400 - _VERIFY(STATUS) end if if ( DelLon_ < 0.0 ) then ! convention for global grids if ( IM_World_ == 1 ) then @@ -2079,8 +1845,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Give the IMs, JMs and LMs the MAPL default distribution ! ------------------------------------------------------- - allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), stat=STATUS) - _VERIFY(STATUS) + allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), _STAT) call MAPL_DecomposeDim ( IM_World_, IMs, Nx_ ) call MAPL_DecomposeDim ( JM_World_, JMs, Ny_ ) call MAPL_DecomposeDim ( LM_World_, LMs, Nz_ ) @@ -2105,8 +1870,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep3 = (/3/), & gridEdgeLWidth = (/0,0,0/), & gridEdgeUWidth = (/0,0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) #else Grid = ESMF_GridCreate( & name=Name, & @@ -2117,11 +1881,9 @@ module function MAPL_LatLonGridCreate (Name, vm, & gridEdgeUWidth = (/0,0/), & coordDep1 = (/1,2/), & coordDep2 = (/1,2/), & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, _RC) #endif @@ -2136,15 +1898,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep2 = (/1,2/), & gridEdgeLWidth = (/0,0/), & gridEdgeUWidth = (/0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) ! Other possibilities not implemented yet ! --------------------------------------- else STATUS = 300 - _VERIFY(STATUS) endif @@ -2156,8 +1916,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Allocate coords at default stagger location ! ------------------------------------------- - call ESMF_GridAddCoord(Grid, rc=status) - _VERIFY(STATUS) + call ESMF_GridAddCoord(Grid, _RC) ! Compute the coordinates (the corner/center is for backward compatibility) ! ------------------------------------------------------------------------- @@ -2166,8 +1925,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & minCoord(1) = MAPL_DEGREES_TO_RADIANS_R8 * BegLon_ - deltaX/2 minCoord(2) = MAPL_DEGREES_TO_RADIANS_R8 * BegLat_ - deltaY/2 - allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), stat=STATUS) - _VERIFY(STATUS) + allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), _STAT) cornerX(1) = minCoord(1) do i = 1,IM_World_ @@ -2183,13 +1941,11 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------------------------------------- call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerX, rc=status) - _VERIFY(STATUS) + farrayPtr=centerX, _RC) call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerY, rc=status) - _VERIFY(STATUS) + farrayPtr=centerY, _RC) FirstOut(1)=BegLon_ FirstOut(2)=-90. @@ -2221,8 +1977,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Make sure we've got it right ! ---------------------------- - call ESMF_GridValidate(Grid,rc=status) - _VERIFY(STATUS) + call ESMF_GridValidate(Grid,_RC) ! Clean up ! -------- @@ -2242,7 +1997,6 @@ subroutine parseConfig_() ! Internal routine to parse the ESMF_Config. ! STATUS = 200 ! not implemented yet - _VERIFY(STATUS) end subroutine parseConfig_ @@ -2267,32 +2021,25 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) real(ESMF_KIND_R8), allocatable :: r8ptr(:),lons1d(:),lats1d(:) type(ESMF_CoordSys_Flag) :: coordSys - call MAPL_GridGet(grid,localCellCountPerDim=counts,rc=status) - _VERIFY(status) + call MAPL_GridGet(grid,localCellCountPerDim=counts,_RC) im=counts(1) jm=counts(2) ! check if we have corners call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - isPresent=hasLons, RC=STATUS) - _VERIFY(status) + isPresent=hasLons, _RC) call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - isPresent=hasLats, RC=STATUS) - _VERIFY(status) + isPresent=hasLats, _RC) if (hasLons .and. hasLats) then call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLons,1)*size(gridCornerLons,2)==lsz,"stored corner sizes to not match grid") call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLats,1)*size(gridCornerLats,2)==lsz,"stored corner sizes to not match grid") - allocate(r8ptr(lsz),stat=status) - _VERIFY(status) + allocate(r8ptr(lsz),_STAT) call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2303,8 +2050,7 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) end do call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2317,47 +2063,36 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) else call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) + farrayPtr=corner, _RC) imc=size(corner,1) jmc=size(corner,2) - allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,stat=status) - _VERIFY(status) - field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],rc=status) - _VERIFY(status) - call ESMF_FieldHaloStore(field,rh,rc=status) - _VERIFY(status) + allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,_STAT) + field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],_RC) + call ESMF_FieldHaloStore(field,rh,_RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLons=ptr(1:im+1,1:jm+1) call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) - _VERIFY(status) + farrayPtr=corner, _RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLats=ptr(1:im+1,1:jm+1) deallocate(ptr) - call ESMF_FieldDestroy(field,rc=status) - _VERIFY(status) - call ESMF_FieldHaloRelease(rh,rc=status) - _VERIFY(status) + call ESMF_FieldDestroy(field,_RC) + call ESMF_FieldHaloRelease(rh,_RC) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(status) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) if (coordSys==ESMF_COORDSYS_SPH_DEG) then gridCornerLons=gridCornerLons*MAPL_DEGREES_TO_RADIANS_R8 gridCornerLats=gridCornerLats*MAPL_DEGREES_TO_RADIANS_R8 else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) - allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) + allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) + allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) idx = 0 do j=1,size(gridCornerLons,2) do i=1,size(gridCornerLons,1) @@ -2367,11 +2102,9 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) enddo enddo call ESMF_AttributeSet(grid, name='GridCornerLons:', & - itemCount = idx, valueList=lons1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lons1d, _RC) call ESMF_AttributeSet(grid, name='GridCornerLats:', & - itemCount = idx, valueList=lats1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lats1d, _RC) deallocate(lons1d,lats1d) end if @@ -2402,17 +2135,18 @@ module subroutine MAPL_GridGetInterior(GRID,I1,IN,J1,JN) integer :: nDEs integer :: deId integer :: gridRank + integer :: rc - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, vm=vm, _RC) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, _RC) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -2508,37 +2242,26 @@ recursive module subroutine MAPL_StateAttSetI4(STATE, NAME, VALUE, RC) integer :: ITEMCOUNT integer :: I - call ESMF_AttributeSet(STATE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(STATE, NAME, VALUE, _RC) - call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,_RC) IF (ITEMCOUNT>0) then - allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES(ITEMCOUNT),_STAT) + allocate(ITEMTYPES(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE, ITEMNAMELIST=ITEMNAMES, & - ITEMTYPELIST=ITEMTYPES, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES, _RC) do I = 1, ITEMCOUNT if(itemtypes(I)==ESMF_StateItem_State) then - call ESMF_StateGet(STATE, itemNames(I), nestedState, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(nestedState, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), nestedState, _RC) + call MAPL_AttributeSet(nestedState, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_FieldBundle) then - call ESMF_StateGet(STATE, itemNames(I), BUNDLE, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), BUNDLE, _RC) + call MAPL_AttributeSet(BUNDLE, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_Field) then - call ESMF_StateGet(STATE, itemNames(I), FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), FIELD, _RC) + call MAPL_AttributeSet(FIELD, NAME, VALUE, _RC) end if end do @@ -2563,17 +2286,13 @@ module subroutine MAPL_BundleAttSetI4(BUNDLE, NAME, VALUE, RC) integer :: FIELDCOUNT integer :: I - call ESMF_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(BUNDLE, NAME, VALUE, _RC) - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) end do _RETURN(ESMF_SUCCESS) @@ -2593,17 +2312,13 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) type(ESMF_FieldStatus_Flag) :: fieldStatus - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if(fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) - call ESMF_AttributeSet(array, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) + call ESMF_AttributeSet(array, NAME, VALUE, _RC) end if _RETURN(ESMF_SUCCESS) @@ -2623,17 +2338,13 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) integer :: STATUS - isCreated = ESMF_FieldBundleIsCreated(bundle,rc=status) - _VERIFY(STATUS) + isCreated = ESMF_FieldBundleIsCreated(bundle,_RC) if(isCreated) then - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldDestroy(FIELD, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call MAPL_FieldDestroy(FIELD, _RC) end do end if @@ -2661,49 +2372,40 @@ module subroutine MAPL_StateAddField(State, Field, RC) logical :: haveAttr fields(1) = field - call ESMF_StateAdd(state, fields, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, fields, _RC) !================= !!!ALT Example to add one field at the time (not used anymore) !!! call ESMF_StateAdd(STATE, FIELD, proxyflag=.false., & -!!! addflag=.true., replaceflag=.false., RC=STATUS ) +!!! addflag=.true., replaceflag=.false., _RC ) !================= ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2732,44 +2434,35 @@ module subroutine MAPL_StateAddBundle(State, Bundle, RC) logical :: haveAttr bundles(1) = bundle - call ESMF_StateAdd(state, Bundles, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, Bundles, _RC) ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldBundleGet(bundle, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(bundle, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2799,44 +2492,35 @@ module subroutine MAPL_FieldBundleAddField(Bundle, Field, multiflag, RC) fields(1) = field - call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, _RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(bundle, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(bundle, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2863,18 +2547,14 @@ module subroutine MAPL_FieldBundleGetByIndex(Bundle, fieldIndex, Field, RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) + allocate(currList(natt), _STAT) ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) name = currList(fieldIndex) - call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, _RC) deallocate(currList) @@ -2926,8 +2606,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) ! pass in the the dimensions of the grid and we must compute them ! and assume search on the global domain if (present(Grid)) then - call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) IM = counts(1) @@ -2951,13 +2630,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) call ESMF_AttributeGet(grid, name='GridType', value=grid_type, _RC) if(trim(grid_type) == "Cubed-Sphere") then call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, _RC) call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, rc=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, _RC) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) allocate(corner_lons(im+1,jm+1)) allocate(corner_lats(im+1,jm+1)) allocate(center_lons(im,jm),center_lats(im,jm)) @@ -2971,11 +2647,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,rc=status) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,_RC) ii=-1 jj=-1 - call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,rc=status) - _VERIFY(status) + call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,_RC) deallocate(corner_lons,corner_lats, center_lons,center_lats) else if (localSearch) then @@ -2986,12 +2661,9 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else _FAIL('if not isCubed, localSearch must be .true.') end if - allocate(elons(im+1),stat=status) - _VERIFY(STATUS) - allocate(elats(jm+1),stat=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + allocate(elons(im+1),_STAT) + allocate(elats(jm+1),_STAT) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) elons = lons(:,1) elats = lats(1,:) if (coordSys==ESMF_COORDSYS_SPH_DEG) then @@ -3104,10 +2776,9 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, endif if ( .not. present(grid)) then - _ASSERT(.false., "need a cubed-sphere grid") + _FAIL("need a cubed-sphere grid") endif - call MAPL_GridGet(grid, globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) _ASSERT( IM_WORLD*6 == JM_WORLD, "It only works for cubed-sphere grid") @@ -3210,7 +2881,7 @@ function grid_is_ok(grid) result(OK) type(ESMF_Grid), intent(inout) :: grid logical :: OK integer :: I1, I2, J1, J2, j - real(ESMF_KIND_R8), pointer :: corner_lons(:,:), corner_lats(:,:) + real(ESMF_KIND_R8), allocatable :: corner_lons(:,:), corner_lats(:,:) real(ESMF_KIND_R8) :: accurate_lat, accurate_lon real :: tolerance @@ -3218,11 +2889,9 @@ function grid_is_ok(grid) result(OK) call MAPL_GridGetInterior(grid,I1,I2,J1,J2) OK = .true. ! check the edge of face 1 along longitude - call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lons, rc=status) - call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lats, rc=status) - + allocate(corner_lons(I2-I1+2, J2-J1+2)) + allocate(corner_lats(I2-I1+2, J2-J1+2)) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats) if ( I1 ==1 .and. J2<=IM_WORLD ) then if (J1 == 1) then accurate_lon = 1.750d0*MAPL_PI_R8 - shift @@ -3235,7 +2904,7 @@ function grid_is_ok(grid) result(OK) endif endif - do j = J1+1, J2 + do j = J1, J2+1 accurate_lat = -alpha + (j-1)*dalpha if ( abs(accurate_lat - corner_lats(1,j-J1+1)) > 5.0*tolerance) then print*, "accurate_lat: ", accurate_lat @@ -3432,16 +3101,14 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un integer :: gridRank type(ESMF_Field) :: field - allocate(localIs2D(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIs2D(size(fieldNames)),_STAT) if (present(is2D)) then _ASSERT(size(fieldNames) == size(is2D),'inconsistent size of is2D array') localIs2D = is2D else localIs2D = .false. end if - allocate(localIsEdge(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIsEdge(size(fieldNames)),_STAT) if (present(isEdge)) then _ASSERT(size(fieldNames) == size(isEdge), 'inconsistent size of isEdge array') localIsEdge = isEdge @@ -3455,23 +3122,17 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un _ASSERT(size(fieldNames) == size(units), 'inconsistent size of units array') end if - B = ESMF_FieldBundleCreate ( name=name, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_FieldBundleSet ( B, grid=GRID, rc=STATUS ) - _VERIFY(STATUS) + B = ESMF_FieldBundleCreate ( name=name, _RC ) + call ESMF_FieldBundleSet ( B, grid=GRID, _RC ) call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, & - localCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + localCellCountPerDim=DIMS, _RC) do i=1,size(fieldnames) if (localIs2D(i)) then - allocate(PTR2(DIMS(1),DIMS(2)),stat=STATUS) - _VERIFY(STATUS) + allocate(PTR2(DIMS(1),DIMS(2)),_STAT) PTR2 = 0.0 - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) if(gridRank == 2) then gridToFieldMap(1) = 1 gridToFieldMap(2) = 2 @@ -3485,53 +3146,40 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & farrayPtr=PTR2, gridToFieldMap=gridToFieldMap, & - name=fieldNames(i), RC=STATUS) - _VERIFY(STATUS) + name=fieldNames(i), _RC) deallocate(gridToFieldMap) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, _RC) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, _RC) else if (localIsEdge(i)) then - allocate(PTR3(Dims(1),Dims(2),0:counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),0:counts(3)),_STAT) else - allocate(PTR3(Dims(1),Dims(2),counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),counts(3)),_STAT) end if PTR3 = 0.0 FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - farrayPtr=PTR3, name=fieldNames(i), RC=STATUS) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, RC=STATUS) - _VERIFY(STATUS) + farrayPtr=PTR3, name=fieldNames(i), _RC) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, _RC) if (localIsEdge(i)) then - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, _RC) else - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, _RC) end if end if if (present(long_names)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if if (present(units)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if - call MAPL_FieldBundleAdd(B, FIELD, RC=STATUS) - _VERIFY(STATUS) + call MAPL_FieldBundleAdd(B, FIELD, _RC) enddo deallocate(localIs2D) @@ -3551,11 +3199,9 @@ module function MAPL_TrimString(istring,rc) result(ostring) strlen = len_trim(istring) if (istring(strlen:strlen)==char(0)) then - allocate(ostring,source=istring(1:strlen-1),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen-1),_STAT) else - allocate(ostring,source=istring(1:strlen),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen),_STAT) end if _RETURN(_SUCCESS) end function MAPL_TrimString @@ -3570,160 +3216,67 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) integer :: status integer :: k, n integer :: k1,k2,kk - integer :: gridRank - logical :: has_ungrd integer :: ungrd_cnt integer :: fieldRank - integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungrd(:) - real, pointer :: ptr4d(:,:,:,:) => null() - real, pointer :: ptr3d(:,:,:) => null() - real, pointer :: ptr2d(:,:) => null() + integer, allocatable :: localMinIndex(:), localMaxIndex(:) type(ESMF_Field) :: f, fld - type(ESMF_Grid) :: grid - type(ESMF_TypeKind_Flag) :: tk character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXSTR) :: splitName character(len=ESMF_MAXSTR), allocatable :: splitNameArray(:) character(len=ESMF_MAXSTR) :: longName - ! get ptr - ! loop over 3-d or 4-d dim - ! create 2d or 3d field - ! put in state/bundle - ! end-of-loop - call ESMF_FieldGet(field, name=name, grid=grid, typekind=tk, rc=status) - _VERIFY(STATUS) - - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, rc=status) - _VERIFY(STATUS) - - if (tk == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(FIELD, dimCount=fieldRank, rc=status) - _VERIFY(STATUS) - if (fieldRank == 4) then - - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr4D,rc=status) - _VERIFY(STATUS) - n = size(ptr4d,4) - allocate(fields(n), stat=status) - _VERIFY(STATUS) - n = 0 - k1=lbound(ptr4d,4) - k2=ubound(ptr4d,4) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) - _VERIFY(STATUS) - - do k=k1,k2 - n = n+1 - ptr3d => ptr4d(:,:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) - - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if + call ESMF_FieldGet(field, name=name, _RC) - fields(n) = f - end do - else if (fieldRank == 3) then - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr3D,rc=status) - _VERIFY(STATUS) - n = size(ptr3d,3) - allocate(fields(n), stat=status) - _VERIFY(STATUS) - n = 0 - k1=lbound(ptr3d,3) - k2=ubound(ptr3d,3) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) - _VERIFY(STATUS) - do k=k1,k2 - n = n+1 - ptr2d => ptr3d(:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) - - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if + call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) - fields(n) = f - end do + allocate(localMinIndex(fieldRank),localMaxIndex(fieldRank), _STAT) + call ESMF_FieldGet(Field, & + localMinIndex=localMinIndex, localMaxIndex=localMaxIndex, _RC) + + k1 = localMinIndex(fieldRank) + k2 = localMaxIndex(fieldRank) + deallocate(localMinIndex,localMaxIndex) + + n = k2 - k1 + 1 + + allocate(fields(n), _STAT) + + call genAlias(name, n, splitNameArray, aliasName=aliasName,_RC) + + n = 0 + do k=k1,k2 + n = n+1 + splitName = splitNameArray(n) + f = ESMF_FieldCreate(field, & + datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUngridSlice=[k], name=splitName, _RC) + + ! copy attributes and adjust as necessary + fld = field ! shallow copy to get around intent(in/out) + call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, _RC) + + ! adjust ungridded dims attribute (if any) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) + if (has_ungrd) then + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) + call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', _RC) + if (ungrd_cnt > 1) then + ungrd_cnt = ungrd_cnt - 1 + call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & + valueList=UNGRD(1:ungrd_cnt), _RC) + else + has_ungrd = .false. + end if + deallocate(ungrd) end if - else if (tk == ESMF_TYPEKIND_R8) then - _FAIL( "R8 overload not implemented yet") - end if - deallocate(gridToFieldMap) + fields(n) = f + end do + deallocate(splitNameArray) ! fields SHOULD be deallocated by the caller!!! @@ -3785,8 +3338,7 @@ subroutine genAlias(name, n, splitNameArray, aliasName, rc) aliasName_ = name end if - allocate(splitNameArray(n), stat=status) - _VERIFY(status) + allocate(splitNameArray(n), _STAT) ! parse the aliasName ! count the separators (";") in aliasName @@ -3836,8 +3388,7 @@ module function MAPL_GetCorrectedPhase(gc,rc) result(phase) integer :: status - call ESMF_GridCompGet(gc,currentPhase=phase,rc=status) - _VERIFY(status) + call ESMF_GridCompGet(gc,currentPhase=phase,_RC) if (phase>10) phase=phase-10 _RETURN(_SUCCESS) end function MAPL_GetCorrectedPhase diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 268d7291f6f4..02aa55f6af08 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -69,7 +69,7 @@ esma_add_library( ${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 MAPL.field_utils PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL_SHARED::gftl-shared-v1 GFTL::gftl-v2 GFTL::gftl-v1 - esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran + ESMF::ESMF NetCDF::NetCDF_Fortran MPI::MPI_Fortran TYPE ${MAPL_LIBRARY_TYPE}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 @@ -77,11 +77,6 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -# Workaround for bizarre switch in ESMF -if (ESMF_HAS_ACHAR_BUG) - set_source_files_properties(MAPL_Config.F90 PROPERTIES COMPILE_DEFINITIONS ESMF_HAS_ACHAR_BUG) -endif() - if(DISABLE_GLOBAL_NAME_WARNING) target_compile_options (${this} PRIVATE $<$:${DISABLE_GLOBAL_NAME_WARNING}>) endif() @@ -95,7 +90,7 @@ foreach(dir ${OSX_EXTRA_LIBRARY_PATH}) target_link_libraries(${this} PUBLIC "-Xlinker -rpath -Xlinker ${dir}") endforeach() -ecbuild_add_executable (TARGET cub2latlon.x SOURCES cub2latlon_regridder.F90 DEPENDS esmf MAPL.shared) +ecbuild_add_executable (TARGET cub2latlon.x SOURCES cub2latlon_regridder.F90 DEPENDS ESMF::ESMF MAPL.shared) target_link_libraries (cub2latlon.x PRIVATE ${this} MAPL.pfio MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 078a0a8a2c1c..58aab4a1f02c 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -115,7 +115,10 @@ module MAPL_CommsMod interface MAPL_BcastShared module procedure MAPL_BcastShared_1DR4 + module procedure MAPL_BcastShared_1DR8 + module procedure MAPL_BcastShared_2DI4 module procedure MAPL_BcastShared_2DR4 + module procedure MAPL_BcastShared_2DR8 end interface interface MAPL_CommsScatterV @@ -1085,6 +1088,30 @@ subroutine MAPL_BcastShared_1DR4(VM, Data, N, Root, RootOnly, rc) end subroutine MAPL_BcastShared_1DR4 + subroutine MAPL_BcastShared_1DR8(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + real(kind=REAL64), pointer, intent(INOUT) :: Data(:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + integer :: status + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) + else + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_1DR8 + subroutine MAPL_BcastShared_2DR4(VM, Data, N, Root, RootOnly, rc) type(ESMF_VM) :: VM real, pointer, intent(INOUT) :: Data(:,:) @@ -1117,6 +1144,55 @@ subroutine MAPL_BcastShared_2DR4(VM, Data, N, Root, RootOnly, rc) end subroutine MAPL_BcastShared_2DR4 + + subroutine MAPL_BcastShared_2DR8(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + real(kind=REAL64), pointer, intent(INOUT) :: Data(:,:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + integer :: status + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) + else + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_2DR8 + + subroutine MAPL_BcastShared_2DI4(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + integer, pointer, intent(INOUT) :: Data(:,:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + integer :: status + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) + else + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_2DI4 + ! Rank 0 !--------------------------- #define RANK_ 0 diff --git a/base/MAPL_Config.F90 b/base/MAPL_Config.F90 index f31daf1cc93d..7c814348cf8f 100644 --- a/base/MAPL_Config.F90 +++ b/base/MAPL_Config.F90 @@ -48,13 +48,9 @@ module MAPL_ConfigMod character, parameter :: BLK = achar(32) ! blank (space) character, parameter :: TAB = achar(09) ! TAB -#if defined(ESMF_HAS_ACHAR_BUG) - character, parameter :: EOL = achar(12) ! end of line mark (cr) -#else - character, parameter :: EOL = achar(10) ! end of line mark (newline) -#endif - character, parameter :: EOB = achar(00) ! end of buffer mark (null) - character, parameter :: NUL = achar(00) ! what it says + character, parameter :: EOL = achar(10) ! end of line mark (newline) + character, parameter :: EOB = achar(00) ! end of buffer mark (null) + character, parameter :: NUL = achar(00) ! what it says contains @@ -97,7 +93,7 @@ end function MAPL_ConfigCreate ! subroutine MAPL_ConfigSetAttribute_real64( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: REAL64 -! +! type(ESMF_Config), intent(inout) :: config real(kind=REAL64), intent(in) :: value character(len=*), intent(in), optional :: label @@ -243,7 +239,7 @@ end subroutine MAPL_ConfigSetAttribute_real64 ! subroutine MAPL_ConfigSetAttribute_real32( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: REAL32 -! +! type(ESMF_Config), intent(inout) :: config real(kind=REAL32), intent(in) :: value character(len=*), intent(in), optional :: label @@ -376,17 +372,17 @@ subroutine MAPL_ConfigSetAttribute_real32( config, value, label, rc ) end subroutine MAPL_ConfigSetAttribute_real32 !------------------------------------------------------------------------------ -!> +!> ! Set a 4-byte integer _value_ in the _config_ object. -! +! ! The arguments are: !- **config**: Already created `ESMF_Config` object. !- **value**: Integer value to set. !- **label**: Identifying attribute label. !- **rc**: Return code; equals `ESMF_SUCCESS` if there are no errors. -! +! ! **Private name**: call using ESMF_ConfigSetAttribute()`. -! +! subroutine MAPL_ConfigSetAttribute_int32( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: INT32 ! @@ -600,15 +596,15 @@ subroutine MAPL_ConfigSetAttribute_reals32( config, value, label, rc ) end subroutine MAPL_ConfigSetAttribute_reals32 !------------------------------------------------------------------------------ -!> +!> ! Set a string _value_ in the _config_ object. -! +! ! The arguments are: !- **config**: Already created `ESMF_Config` object. !- **value**: String value to set. !- **label**: Identifying attribute label. !- **rc**: Return code; equals `ESMF_SUCCESS` if there are no errors. -! +! subroutine MAPL_ConfigSetAttribute_string(config, value, label, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: value diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 581545b41c57..1c3189fc6c60 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -12,6 +12,7 @@ module MAPL_EsmfRegridderMod use MAPL_GridManagerMod use MAPL_BaseMod, only: MAPL_undef, MAPL_GridHasDE use MAPL_RegridderSpecRouteHandleMap + use MAPL_ConstantsMod implicit none private @@ -138,7 +139,7 @@ subroutine regrid_scalar_2d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -193,7 +194,7 @@ subroutine regrid_scalar_2d_real64(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -245,7 +246,7 @@ subroutine transpose_regrid_scalar_2d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -328,7 +329,7 @@ subroutine regrid_scalar_3d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -411,7 +412,7 @@ subroutine regrid_scalar_3d_real64(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -492,7 +493,7 @@ subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -581,7 +582,7 @@ subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -675,7 +676,7 @@ subroutine regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -765,7 +766,7 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -881,7 +882,7 @@ subroutine regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -990,7 +991,7 @@ subroutine regrid_vector_3d_real64(this, u_in, v_in, u_out, v_out, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -1107,7 +1108,7 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true.,rc=status) @@ -1430,10 +1431,11 @@ subroutine create_route_handle(this, kind, rc) integer :: srcTermProcessing integer, pointer :: factorIndexList(:,:) + integer, allocatable :: dstMaskValues(:) real(ESMF_KIND_R8), pointer :: factorList(:) type(ESMF_RouteHandle) :: dummy_rh type(ESMF_UnmappedAction_Flag) :: unmappedaction - logical :: global, isPresent + logical :: global, isPresent, has_mask type(RegridderSpecRouteHandleMap), pointer :: route_handles, transpose_route_handles type(ESMF_RouteHandle) :: route_handle, transpose_route_handle @@ -1482,6 +1484,8 @@ subroutine create_route_handle(this, kind, rc) dst_dummy_r8 = 0 end if end if + call ESMF_GridGetItem(spec%grid_out,itemflag=ESMF_GRIDITEM_MASK, & + staggerloc=ESMF_STAGGERLOC_CENTER, isPresent = has_mask, _RC) counter = counter + 1 @@ -1491,18 +1495,19 @@ subroutine create_route_handle(this, kind, rc) call ESMF_AttributeGet(spec%grid_in, name='Global',value=global,rc=status) if (.not.global) unmappedaction=ESMF_UNMAPPEDACTION_IGNORE end if + if (has_mask) dstMaskValues = [MAPL_MASK_OUT] ! otherwise unallocated select case (spec%regrid_method) case (REGRID_METHOD_BILINEAR, REGRID_METHOD_BILINEAR_MONOTONIC) - call ESMF_FieldRegridStore(src_field, dst_field, & + & dstMaskValues = dstMaskValues, & & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? & srcTermProcessing = srcTermProcessing, & & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) + & routehandle=route_handle, unmappedaction=unmappedaction, _RC) case (REGRID_METHOD_PATCH) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_PATCH, & & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? @@ -1512,6 +1517,7 @@ subroutine create_route_handle(this, kind, rc) _VERIFY(status) case (REGRID_METHOD_CONSERVE_2ND) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, & & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? @@ -1520,6 +1526,7 @@ subroutine create_route_handle(this, kind, rc) & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) _VERIFY(status) case (REGRID_METHOD_CONSERVE, REGRID_METHOD_CONSERVE_MONOTONIC, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_CONSERVE, & & srcTermProcessing = srcTermProcessing, & @@ -1527,6 +1534,7 @@ subroutine create_route_handle(this, kind, rc) & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) _VERIFY(status) case (REGRID_METHOD_NEAREST_STOD) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, & & factorList=factorList, factorIndexList=factorIndexList, & diff --git a/base/MAPL_MemUtils.F90 b/base/MAPL_MemUtils.F90 index fa779616fbc1..26a0c331fdee 100755 --- a/base/MAPL_MemUtils.F90 +++ b/base/MAPL_MemUtils.F90 @@ -59,6 +59,7 @@ module MAPL_MemUtilsMod public MAPL_MemUtilsFree public MAPL_MemCommited public MAPL_MemUsed + public MAPL_MemReport #ifdef _CRAY public :: hplen @@ -767,4 +768,32 @@ subroutine get_unit ( iunit ) return end subroutine get_unit +subroutine MAPL_MemReport(comm,file_name,line,decorator,rc) + integer, intent(in) :: comm + character(len=*), intent(in) :: file_name + integer, intent(in) :: line + character(len=*), intent(in), optional :: decorator + integer, intent(out), optional :: rc + + real :: mem_total,mem_used,percent_used + real :: committed_total,committed,percent_committed + integer :: rank,status + character(len=:), allocatable :: extra_message + +#ifdef sysDarwin + _RETURN(ESMF_SUCCESS) +#endif + call MPI_Barrier(comm,status) + if (present(decorator)) then + extra_message = decorator + else + extra_message = "" + end if + call MAPL_MemUsed(mem_total,mem_used,percent_used) + call MAPL_MemCommited(committed_total,committed,percent_committed) + call MPI_Comm_Rank(comm,rank,status) + if (rank == 0) write(*,'("Mem report ",A20," ",A30," ",i7," ",f5.1,"% : ",f5.1,"% Mem Comm:Used")')trim(extra_message),file_name,line,percent_committed,percent_used + +end subroutine + end module MAPL_MemUtilsMod diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index d4ed2f8de5ab..0329e8e16311 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -5,13 +5,21 @@ module MAPL_ObsUtilMod use ESMF use Plain_netCDF_Time use netCDF + use MAPL_BaseMod, only: MAPL_UNDEF use MAPL_CommsMod, only : MAPL_AM_I_ROOT use pFIO_FileMetadataMod, only : FileMetadata use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none integer, parameter :: mx_ngeoval = 60 -!! private + ! GRS80 by Moritz + real(REAL64) :: r_eq=6378137.d0 + real(REAL64) :: r_pol=6356752.31414d0 + real(REAL64) :: H_sat=42164160.d0 + ! GOES-R + real(REAL64) :: lambda0_SatE=-1.308996939d0 ! -75 deg Satellite East + real(REAL64) :: lambda0_SatW=-2.39110107523d0 ! -137 deg Satellite West + real(REAL64) :: lambda0_SatT=-1.56206968053d0 ! -89.5 deg Satellite Test public :: obs_unit type :: obs_unit @@ -33,10 +41,10 @@ module MAPL_ObsUtilMod type obs_platform character (len=ESMF_MAXSTR) :: name='' - character (len=ESMF_MAXSTR) :: nc_index='' - character (len=ESMF_MAXSTR) :: nc_lon='' - character (len=ESMF_MAXSTR) :: nc_lat='' - character (len=ESMF_MAXSTR) :: nc_time='' + character (len=ESMF_MAXSTR) :: index_name_x='' + character (len=ESMF_MAXSTR) :: var_name_lon='' + character (len=ESMF_MAXSTR) :: var_name_lat='' + character (len=ESMF_MAXSTR) :: var_name_time='' character (len=ESMF_MAXSTR) :: file_name_template='' integer :: ngeoval=0 integer :: nentry_name=0 @@ -62,7 +70,7 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & integer, intent(out) :: obsfile_Te_index integer, optional, intent(out) :: rc - type(ESMF_Time) :: T1, Tn + type(ESMF_Time) :: T1 type(ESMF_Time) :: cT1 type(ESMF_Time) :: Ts, Te type(ESMF_TimeInterval) :: dT1, dT2, dTs, dTe @@ -71,8 +79,14 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & integer :: n1, n2 integer :: status + ! + ! o---------o ------------- o -------------o + ! obsfile_interval + ! x---------------------x-- + ! Epoch + ! + T1 = obsfile_start_time - Tn = obsfile_end_time cT1 = currTime dT1 = currTime - T1 @@ -91,11 +105,7 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & Te = T1 + dTe obsfile_Ts_index = n1 - if ( dT2_s - n2*dT0_s < 1 ) then - obsfile_Te_index = n2 - 1 - else - obsfile_Te_index = n2 - end if + obsfile_Te_index = n2 _RETURN(ESMF_SUCCESS) @@ -177,7 +187,7 @@ end subroutine reset_times_to_current_day ! --//-------------------------------------//-> ! files ! o o o o o o o o o o T: filename - ! <--- off set + ! <--- off set ! o o o o o o o o o o T: file content start ! | | ! curr curr+Epoch @@ -210,6 +220,7 @@ subroutine Find_M_files_for_currTime (currTime, & integer :: n1, n2 integer :: i, j integer :: status + logical :: exist !__ s1. Arithmetic index list based on s,e,interval ! @@ -254,13 +265,13 @@ subroutine Find_M_files_for_currTime (currTime, & ! print*, '2nd n1, n2', n1, n2 !__ s2. further test file existence - ! + ! j=0 do i= n1, n2 test_file = get_filename_from_template_use_index & (obsfile_start_time, obsfile_interval, & - i, file_template, rc=rc) - if (test_file /= '') then + i, file_template, exist, rc=rc) + if (exist) then j=j+1 filenames(j) = test_file end if @@ -269,7 +280,6 @@ subroutine Find_M_files_for_currTime (currTime, & _ASSERT ( M < size(filenames) , 'code crash, number of files exceeds upper bound') _ASSERT (M/=0, 'M is zero, no files found for currTime') - _RETURN(_SUCCESS) @@ -278,8 +288,8 @@ end subroutine Find_M_files_for_currTime subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & index_name_lon, index_name_lat,& - var_name_lon, var_name_lat, var_name_time, & - lon, lat, time, rc ) + var_name_lon, var_name_lat, var_name_time, & + lon, lat, time, Tfilter, rc ) use pFlogger, only: logging, Logger character(len=ESMF_MAXSTR), intent(in) :: filenames(:) integer, intent(out) :: Xdim @@ -288,17 +298,15 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & character(len=ESMF_MAXSTR), intent(in) :: index_name_lat character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lon character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lat - character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time - - real, optional, intent(inout) :: lon(:,:) - real, optional, intent(inout) :: lat(:,:) - !! real(ESMF_KIND_R8), optional, intent(inout) :: time_R8(:,:) - real, optional, intent(inout) :: time(:,:) - + character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lon(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lat(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: time(:,:) + logical, optional, intent(in) :: Tfilter integer, optional, intent(out) :: rc integer :: M - integer :: i, j, jx, status + integer :: i, j, jx, j2, status integer :: nlon, nlat integer :: ncid, ncid2 character(len=ESMF_MAXSTR) :: grp1, grp2 @@ -316,7 +324,7 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & M = size(filenames) _ASSERT(M/=0, 'M is zero, no files found') lgr => logging%get_logger('MAPL.Sampler') - + allocate(nlons(M), nlats(M)) jx=0 do i = 1, M @@ -326,45 +334,140 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & nlons(i)=nlon nlats(i)=nlat jx=jx+nlat - + call lgr%debug('Input filename: %a', trim(filename)) call lgr%debug('Input file : nlon, nlat= %i6 %i6', nlon, nlat) end do + ! + ! __ output results wo filter + ! Xdim=nlon Ydim=jx - + j2=jx !__ s2. get fields - jx=0 - do i = 1, M - filename = filenames(i) - nlon = nlons(i) - nlat = nlats(i) - if (present(var_name_time).AND.present(time)) then + if ( present(Tfilter) .AND. Tfilter ) then + if ( .not. (present(time) .AND. present(lon) .AND. present(lat)) ) then + _FAIL('when Tfilter present, time/lon/lat must also present') + end if + + ! + ! -- determine jx + ! + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) allocate (time_loc_R8(nlon, nlat)) call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) - time(1:nlon,jx+1:jx+nlat) = time_loc_R8(1:nlon,1:nlat) +!! write(6,*) 'af ith, filename', i, trim(filename) + + do j=1, nlat + ! + ! -- filter, e.g., eliminate -9999 + ! + if ( time_loc_R8(1, j) > 0.0 ) then + jx = jx + 1 + end if + end do deallocate(time_loc_R8) + end do + Xdim=nlon + Ydim=jx + if (allocated (time)) then + deallocate(time) + allocate (time(Xdim, Ydim)) end if - - if (present(var_name_lon).AND.present(lon)) then + if (allocated (lon)) then + deallocate(lon) + allocate (lon(Xdim, Ydim)) + end if + if (allocated (lat)) then + deallocate(lat) + allocate (lat(Xdim, Ydim)) + end if + ! + !!write(6,'(2x,a,10i10)') 'true Xdim, Ydim:', Xdim, Ydim + !!write(6,'(2x,a,10i10)') 'false Xdim, Ydim:', nlon, j2 + ! + + + ! + ! -- determine true time/lon/lat by filtering T < 0 + ! + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) + !!write(6,'(2x,a,10i6)') 'M, i, nlon, nlat:', M, i, nlon, nlat + !!write(6,'(2x,a)') 'time_loc_r8' + ! + allocate (time_loc_R8(nlon, nlat)) + call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) allocate (lon_loc(nlon, nlat)) call get_var_from_name_w_group (var_name_lon, lon_loc, filename, _RC) - lon(1:nlon,jx+1:jx+nlat) = lon_loc(1:nlon,1:nlat) - deallocate(lon_loc) - end if - - if (present(var_name_lat).AND.present(lat)) then allocate (lat_loc(nlon, nlat)) call get_var_from_name_w_group (var_name_lat, lat_loc, filename, _RC) - lat(1:nlon,jx+1:jx+nlat) = lat_loc(1:nlon,1:nlat) + ! + do j=1, nlat + ! + ! -- filter, e.g., eliminate -9999 + ! + if ( time_loc_R8(1, j) > 0.0 ) then + jx = jx + 1 + time(1:nlon,jx) = time_loc_R8(1:nlon,j) + lon (1:nlon,jx) = lon_loc (1:nlon,j) + lat (1:nlon,jx) = lat_loc (1:nlon,j) + end if + !!write(6,'(5f20.2)') time_loc_R8(1,j) + end do + + !!write(6,'(2x,a,10i10)') 'end of file id', i + !!write(6,*) + + deallocate(time_loc_R8) + deallocate(lon_loc) deallocate(lat_loc) + end do + + else + + if (allocated (time)) then + deallocate(time) + allocate (time(Xdim, Ydim)) + end if + if (allocated (lon)) then + deallocate(lon) + allocate (lon(Xdim, Ydim)) + end if + if (allocated (lat)) then + deallocate(lat) + allocate (lat(Xdim, Ydim)) end if - jx = jx + nlat + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) - end do + if (present(var_name_time).AND.present(time)) then + call get_var_from_name_w_group (var_name_time, time(1:nlon,jx+1:jx+nlat), filename, _RC) + end if + if (present(var_name_lon).AND.present(lon)) then + call get_var_from_name_w_group (var_name_lon, lon(1:nlon,jx+1:jx+nlat), filename, _RC) + end if + if (present(var_name_lat).AND.present(lat)) then + call get_var_from_name_w_group (var_name_lat, lat(1:nlon,jx+1:jx+nlat), filename, _RC) + end if + + jx = jx + nlat + end do + + end if _RETURN(_SUCCESS) end subroutine read_M_files_4_swath @@ -375,14 +478,15 @@ end subroutine read_M_files_4_swath ! because of (bash ls) command therein ! function get_filename_from_template_use_index (obsfile_start_time, obsfile_interval, & - f_index, file_template, rc) result(filename) + f_index, file_template, exist, rc) result(filename) use Plain_netCDF_Time, only : ESMF_time_to_two_integer - use MAPL_StringTemplate, only : fill_grads_template + use MAPL_StringTemplate, only : fill_grads_template character(len=ESMF_MAXSTR) :: filename type(ESMF_Time), intent(in) :: obsfile_start_time type(ESMF_TimeInterval), intent(in) :: obsfile_interval character(len=*), intent(in) :: file_template integer, intent(in) :: f_index + logical, intent(out) :: exist integer, optional, intent(out) :: rc integer :: itime(2) @@ -393,7 +497,6 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_TimeInterval) :: dT type(ESMF_Time) :: time integer :: i, j, u - logical :: EX character(len=ESMF_MAXSTR) :: file_template_left character(len=ESMF_MAXSTR) :: file_template_right @@ -415,8 +518,7 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! call fill_grads_template ( filename, file_template, & experiment_id='', nymd=nymd, nhms=nhms, _RC ) - inquire(file= trim(filename), EXIST = EX) - if(.not.EX) filename='' + inquire(file= trim(filename), EXIST = exist) _RETURN(_SUCCESS) @@ -431,8 +533,8 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) integer :: i, j character(len=ESMF_MAXSTR) :: grp1, grp2 - character(len=ESMF_MAXSTR) :: short_name - integer :: ncid, ncid2, varid + character(len=ESMF_MAXSTR) :: short_name + integer :: ncid, ncid1, ncid2, ncid_final, varid logical :: found_group integer :: status @@ -447,7 +549,7 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) short_name=var_name(i+j+1:) else grp2='' - short_name=var_name(i+1:) + short_name=var_name(i+1:) endif i=i+j else @@ -457,20 +559,29 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) short_name=var_name endif - call check_nc_status(nf90_open(filename, NF90_NOWRITE, ncid2), _RC) + + ! ncid + ! ncid1: grp1 + ! ncid2: grp2 + ! + call check_nc_status(nf90_open(filename, NF90_NOWRITE, ncid), _RC) + ncid_final = ncid if ( found_group ) then - call check_nc_status(nf90_inq_ncid(ncid2, grp1, ncid), _RC) + call check_nc_status(nf90_inq_ncid(ncid, grp1, ncid1), _RC) + ncid_final = ncid1 if (j>0) then - call check_nc_status(nf90_inq_ncid(ncid, grp2, ncid2), _RC) - ncid=ncid2 + call check_nc_status(nf90_inq_ncid(ncid1, grp2, ncid2), _RC) + ncid_final = ncid2 endif else - print*, 'no grp name' - ncid=ncid2 +!! print*, 'no grp name' endif - call check_nc_status(nf90_inq_varid(ncid, short_name, varid), _RC) - call check_nc_status(nf90_get_var(ncid, varid, var2d), _RC) -!! call check_nc_status(nf90_close(ncid), _RC) + + call check_nc_status(nf90_inq_varid(ncid_final, short_name, varid), _RC) +!! write(6,*) 'ncid, short_name, varid', ncid, trim(short_name), varid + call check_nc_status(nf90_get_var(ncid_final, varid, var2d), _RC) + + call check_nc_status(nf90_close(ncid), _RC) _RETURN(_SUCCESS) @@ -557,16 +668,15 @@ subroutine sort_four_arrays_by_time(U,V,T,ID,rc) end subroutine sort_four_arrays_by_time - function copy_platform_nckeys(a, rc) type(obs_platform) :: copy_platform_nckeys type(obs_platform), intent(in) :: a integer, optional, intent(out) :: rc - copy_platform_nckeys%nc_index = a%nc_index - copy_platform_nckeys%nc_lon = a%nc_lon - copy_platform_nckeys%nc_lat = a%nc_lat - copy_platform_nckeys%nc_time = a%nc_time + copy_platform_nckeys%index_name_x = a%index_name_x + copy_platform_nckeys%var_name_lon = a%var_name_lon + copy_platform_nckeys%var_name_lat = a%var_name_lat + copy_platform_nckeys%var_name_time = a%var_name_time copy_platform_nckeys%nentry_name = a%nentry_name _RETURN(_SUCCESS) @@ -621,4 +731,115 @@ function union_platform(a, b, rc) end function union_platform + ! From GOES-R SERIES PRODUCT DEFINITION AND USERS’ GUIDE + ! + subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, mask) + implicit none + real(REAL64), intent(in) :: x, y + real(REAL64), intent(in) :: lambda0 + real(REAL64), intent(out):: lon, lat + integer, optional, intent(out):: mask + real(REAL64) :: a0, b0, c0, rs, Sx, Sy, Sz, t + real(REAL64) :: a, b, H + real(REAL64) :: delta + + a=r_eq; b=r_pol; H=H_sat + + if (present(mask)) mask=0 + a0 = sin(x)*sin(x) + cos(x)*cos(x)*( cos(y)*cos(y) + (a/b)*(a/b)*sin(y)*sin(y) ) + b0 = -2.d0 * H * cos(x) * cos(y) + c0 = H*H - a*a + delta = b0*b0 - 4.d0*a0*c0 + if (delta < 0.d0) then + lon = MAPL_UNDEF + lat = MAPL_UNDEF + if (present(mask)) mask=0 + return + end if + rs = ( -b0 - sqrt(b0*b0 - 4.d0*a0*c0) ) / (2.d0*a0) + Sx = rs * cos(x) * cos(y) + Sy = -rs * sin(x) + Sz = rs * cos(x) * sin(y) + lon = lambda0 - atan (Sy/(H - Sx)) + lat = atan ( (a/b)**2.d0 * Sz / sqrt ((H -Sx)**2.d0 + Sy*Sy) ) + + t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) + if (t < 0) then + lon = MAPL_UNDEF + lat = MAPL_UNDEF + if (present(mask)) mask=0 + else + if (present(mask)) mask=1 + end if + + end subroutine ABI_XY_2_lonlat + + + subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, mask) + implicit none + real(REAL64), intent(in) :: lon, lat + real(REAL64), intent(in) :: lambda0 + real(REAL64), intent(out):: x, y + integer, intent(out):: mask + real(REAL64) :: theta_c + real(REAL64) :: e2, rc, Sx, Sy, Sz, t + real(REAL64) :: a, b, H + real*8 :: delta + + a=r_eq; b=r_pol; H=H_sat + + theta_c = atan( (b/a)**2.d0 * tan(lat) ) + e2 = 1.d0 - (b/a)**2.d0 ! (a^2-b^2)/a^2 + rc = b / sqrt( 1.d0 - e2 * cos(theta_c)**2.d0 ) + Sx = H - rc * cos(theta_c) * cos( lon - lambda0 ) + Sy = - rc * cos(theta_c) * sin( lon - lambda0 ) + Sz = rc * sin(theta_c) + x = - asin ( Sy / sqrt (Sx*Sx + Sy*Sy + Sz*Sz) ) + y = atan ( Sz / Sx ) + + t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) + if (t < 0) then + mask = 1 + else + mask = 0 + end if + + end subroutine lonlat_2_ABI_XY + + + subroutine test_conversion + implicit none + real*8 :: x0 + real*8 :: y0 + real*8 :: lam, the + real*8 :: lon, lat + integer :: mask + real*8 :: xnew, ynew + + ! two points mapping: (x0, y0) <--> (lam, the) + x0 = -0.024052d0 + y0 = 0.095340d0 + lam = -1.478135612d0 + the = 0.590726971d0 + + call ABI_XY_2_lonlat (x0, y0, lambda0_SatE, lon, lat, mask) + write(6, 111) 'x,y 2 ll' + write(6, 111) 'x,y=', x0, y0 + write(6, 111) 'lon,lat=', lon, lat + write(6, 121) 'mask=', mask + write(6, 111) 'errror lon,lat=', lon - lam, lat-the + + call lonlat_2_ABI_XY (lam, the, lambda0_SatE, xnew, ynew, mask) + write(6, 111) 'll 2 xy' + write(6, 111) 'lon,lat=', lam, the + write(6, 111) 'x,y=', xnew, ynew + write(6, 121) 'mask=', mask + write(6, 111) 'errror lon,lat=', xnew -x0, ynew-y0 + +101 format (2x, a,10(2x,f15.8)) +111 format (2x, a,20(2x,f25.11)) +121 format (2x, a,10(2x,i8)) + + end subroutine test_conversion + end module MAPL_ObsUtilMod diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 591c9eb562cc..0a403792e9d6 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -26,14 +26,14 @@ module MAPL_SwathGridFactoryMod private public :: SwathGridFactory - + type, extends(AbstractGridFactory) :: SwathGridFactory private character(len=:), allocatable :: grid_name - character(len=:), allocatable :: grid_file_name + character(len=:), allocatable :: grid_file_name character(len=ESMF_MAXSTR) :: filenames(mx_file) integer :: M_file - + integer :: cell_across_swath integer :: cell_along_swath integer :: im_world = MAPL_UNDEFINED_INTEGER @@ -47,7 +47,7 @@ module MAPL_SwathGridFactoryMod ! note: this var is not deallocated in swathfactory, use caution character(len=ESMF_MAXSTR) :: tunit character(len=ESMF_MAXSTR) :: index_name_lon - character(len=ESMF_MAXSTR) :: index_name_lat + character(len=ESMF_MAXSTR) :: index_name_lat character(len=ESMF_MAXSTR) :: var_name_lon character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_time @@ -57,10 +57,10 @@ module MAPL_SwathGridFactoryMod type(ESMF_Time) :: obsfile_start_time ! user specify type(ESMF_Time) :: obsfile_end_time type(ESMF_TimeInterval) :: obsfile_interval - type(ESMF_TimeInterval) :: EPOCH_FREQUENCY + type(ESMF_TimeInterval) :: EPOCH_FREQUENCY integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index - logical :: is_valid + logical :: is_valid ! Domain decomposition: integer :: nx = MAPL_UNDEFINED_INTEGER @@ -130,7 +130,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & integer, optional, intent(in) :: im_world integer, optional, intent(in) :: jm_world integer, optional, intent(in) :: lm - + ! decomposition: integer, optional, intent(in) :: nx integer, optional, intent(in) :: ny @@ -142,7 +142,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & integer :: status _UNUSED_DUMMY(unusable) - + call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) call set_with_default(factory%nx, nx, MAPL_UNDEFINED_INTEGER) call set_with_default(factory%ny, ny, MAPL_UNDEFINED_INTEGER) @@ -155,7 +155,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & if (present(jms)) factory%jms = jms call factory%check_and_fill_consistency(_RC) - + _RETURN(_SUCCESS) end function SwathGridFactory_from_parameters @@ -168,8 +168,13 @@ function make_new_grid(this, unusable, rc) result(grid) integer :: status _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 @@ -199,10 +204,10 @@ function create_basic_grid(this, unusable, rc) result(grid) if (this%lm /= MAPL_UNDEFINED_INTEGER) then call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, _RC) end if - call ESMF_AttributeSet(grid, 'GridType', 'LatLon', _RC) + call ESMF_AttributeSet(grid, 'GridType', 'Swath', _RC) call ESMF_AttributeSet(grid, 'Global', .false., _RC) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) end function create_basic_grid @@ -216,88 +221,106 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) integer :: status real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) - real, pointer :: centers(:,:) - real, allocatable :: centers_full(:,:) - + real(kind=ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lat_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_lon(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_lat(:,:) + integer :: i, j, k integer :: Xdim, Ydim integer :: Xdim_full, Ydim_full integer :: nx, ny - + integer :: IM, JM integer :: IM_WORLD, JM_WORLD integer :: COUNTS(3), DIMS(3) integer :: i_1, i_n, j_1, j_n ! regional array bounds type(Logger), pointer :: lgr + ! debug + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: nsize, count + integer :: mpic + _UNUSED_DUMMY(unusable) - + call ESMF_VMGetCurrent(vm,_RC) +!! call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) + Xdim=this%im_world Ydim=this%jm_world - Xdim_full=this%cell_across_swath - Ydim_full=this%cell_along_swath + count = Xdim * Ydim - call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) + call MAPL_AllocateShared(arr_lon,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) + if (mapl_am_i_root()) then + allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) + call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & + this%index_name_lon, this%index_name_lat, & + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=time_true, & + Tfilter=.true., _RC) + k=0 + do j=this%epoch_index(3), this%epoch_index(4) + k=k+1 + arr_lon(1:Xdim, k) = lon_true(1:Xdim, j) + arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) + enddo + arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 + arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 + deallocate( lon_true, lat_true, time_true ) + +! write(6,*) 'in root' +! write(6,'(11x,100f10.1)') arr_lon(::5,189) + end if +! call MPI_Barrier(mpic, status) + call MAPL_SyncSharedMemory(_RC) + + call MAPL_BcastShared (VM, data=arr_lon, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (VM, data=arr_lat, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + +! write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) +! call MPI_Barrier(mpic, status) + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + fptr=real(arr_lon(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) + call MAPL_SyncSharedMemory(_RC) + + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + fptr=real(arr_lat(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) + + if(MAPL_ShmInitialized) then + call MAPL_DeAllocNodeArray(arr_lon,_RC) + call MAPL_DeAllocNodeArray(arr_lat,_RC) + else + deallocate(arr_lon) + deallocate(arr_lat) + end if ! if (mapl_am_I_root()) then ! write(6,'(2x,a,10i8)') & -! 'ck: Xdim, Ydim, Xdim_full, Ydim_full', Xdim, Ydim, Xdim_full, Ydim_full +! 'ck: Xdim, Ydim', Xdim, Ydim ! write(6,'(2x,a,10i8)') & ! 'ck: i_1, i_n, j_1, j_n', i_1, i_n, j_1, j_n ! end if - - ! read longitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) - call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_lon=this%var_name_lon, lon=centers_full, _RC) - k=0 - do j=this%epoch_index(3), this%epoch_index(4) - k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) - enddo - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - deallocate (centers_full) - end if - call MAPL_SyncSharedMemory(_RC) - call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) - fptr=real(centers(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) - - - ! read latitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) - call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_lat=this%var_name_lat, lat=centers_full, _RC) - k=0 - do j=this%epoch_index(3), this%epoch_index(4) - k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) - enddo - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - deallocate (centers_full) - end if - call MAPL_SyncSharedMemory(_RC) - call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) - fptr=real(centers(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) - - if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(centers,_RC) - else - deallocate(centers) - end if - +! write(6,*) 'MAPL_AmNodeRoot, MAPL_ShmInitialized=', MAPL_AmNodeRoot, MAPL_ShmInitialized +! if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then +! write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet +! end if + _RETURN(_SUCCESS) + end subroutine add_horz_coordinates_from_file @@ -413,12 +436,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer :: nx, ny character(len=ESMF_MAXSTR) :: key_lon, key_lat, key_time character(len=ESMF_MAXSTR) :: tunit, grp1, grp2 - character(len=ESMF_MAXSTR) :: filename, STR1, tmp + character(len=ESMF_MAXSTR) :: filename, STR1, tmp character(len=ESMF_MAXSTR) :: symd, shms - - ! real(ESMF_KIND_R8), allocatable :: scanTime(:,:) - real, allocatable :: scanTime(:,:) + real(ESMF_KIND_R8), allocatable :: scanTime(:,:) + real(ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(ESMF_KIND_R8), allocatable :: lat_true(:,:) integer :: yy, mm, dd, h, m, s, sec, second integer :: i, j, L integer :: ncid, ncid2, varid @@ -429,24 +452,23 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer (ESMF_KIND_I8) :: j0, j1, jt, jt1, jt2 real(ESMF_KIND_R8) :: jx0, jx1 real(ESMF_KIND_R8) :: x0, x1 - integer :: khi, klo, k, nstart, max_iter + integer :: khi, klo, k, nstart, nend, max_iter type(Logger), pointer :: lgr logical :: ispresent - type(ESMF_TimeInterval) :: Toff - + type(ESMF_TimeInterval) :: Toff, obs_time_span + _UNUSED_DUMMY(unusable) lgr => logging%get_logger('HISTORY.sampler') - + call ESMF_VmGetCurrent(VM, _RC) ! input : config ! output: this%epoch_index, nx, ny ! ! Read in specs, crop epoch_index based on scanTime - ! - + !__ s1. read in file spec. ! call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT) @@ -458,41 +480,66 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) + write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& + this%nx,this%ny,this%im_world,this%jm_world,this%lm - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label= prefix// 'obs_file_begin:', _RC) + call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) - if (trim(STR1)=='') then - _FAIL('obs_file_begin missing, code crash') + if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then + call ESMF_TimeSet(currTime, timeString=tmp, _RC) else - call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + read(tmp,'(i4,5i2)') yy,mm,dd,h,m,s + call ESMF_Timeset(currTime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) + endif + second = hms_2_s(this%Epoch) + call ESMF_TimeIntervalSet(this%epoch_frequency, s=second, _RC) + + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label= prefix// 'obs_file_begin:', _RC) + _ASSERT (trim(STR1)/='', 'obs_file_begin missing, critical for data with 5 min interval!') + call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + !!disable using currTime as obsfile_start_time + !!if (trim(STR1)=='') then + !! this%obsfile_start_time = currTime + !! call ESMF_TimeGet(currTime, timestring=STR1, _RC) + !! if (mapl_am_I_root()) then + !! write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) + !! endif + !!else + !! call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + !! if (mapl_am_I_root()) then + !! write(6,105) 'obs_file_begin provided: ', trim(STR1) + !! end if + !!end if + + + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin provided: ', trim(STR1) end if call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label=prefix // 'obs_file_end:', _RC) - if (trim(STR1)=='') then - _FAIL('obs_file_end missing, code crash') + call ESMF_TimeIntervalSet(obs_time_span, d=100, _RC) + this%obsfile_end_time = this%obsfile_start_time + obs_time_span + call ESMF_TimeGet(this%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end missing, default = begin+100D:', trim(STR1) + endif else call ESMF_TimeSet(this%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end provided:', trim(STR1) + end if end if call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label= prefix// 'obs_file_interval:', _RC) _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') + if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) + if (mapl_am_I_root()) write(6,106) 'Epoch (second) :', second - -! if (mapl_am_I_root()) then -! write(6,'(//2x, a)') 'SWATH initialize_from_config_with_prefix' -! print*, 'obs_file_begin: str1=', trim(STR1) -! write(6,105) 'obs_file_begin provided: ', trim(STR1) -! print*, 'obs_file_end: str1=', trim(STR1) -! write(6,105) 'obs_file_end provided:', trim(STR1) -! write(6,105) 'obs_file_interval:', trim(STR1) -! write(6,106) 'Epoch (hhmmss) :', this%epoch -! end if - - i= index( trim(STR1), ' ' ) if (i>0) then symd=STR1(1:i-1) @@ -501,29 +548,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc symd='' shms=trim(STR1) endif - call convert_twostring_2_esmfinterval (symd, shms, this%obsfile_interval, _RC) - - second = hms_2_s(this%Epoch) - call ESMF_TimeIntervalSet(this%epoch_frequency, s=second, _RC) - - if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then - call ESMF_TimeSet(currTime, timeString=tmp, _RC) - else - read(tmp,'(i4,5i2)') yy,mm,dd,h,m,s - call ESMF_Timeset(currTime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) - endif - - call lgr%debug(' %a %a', 'input_template =', trim(this%input_template)) - !!write(6,'(2x,a,/,4i8,/,5(2x,a))') 'nx,ny,lm,epoch -- filename,tmp', & - !! this%nx,this%ny,this%lm,this%epoch,& - !! trim(filename),trim(tmp) - !!print*, 'ck: Epoch_init:', trim(tmp) - + call convert_twostring_2_esmfinterval (symd, shms, this%obsfile_interval, _RC) call ESMF_ConfigGetAttribute(config, value=this%index_name_lon, default="", & label=prefix // 'index_name_lon:', _RC) call ESMF_ConfigGetAttribute(config, value=this%index_name_lat, default="", & - label=prefix // 'index_name_lat:', _RC) + label=prefix // 'index_name_lat:', _RC) call ESMF_ConfigGetAttribute(config, this%var_name_lon, & label=prefix // 'var_name_lon:', default="", _RC) call ESMF_ConfigGetAttribute(config, this%var_name_lat, & @@ -531,15 +561,16 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%var_name_time, default="", & label=prefix//'var_name_time:', _RC) call ESMF_ConfigGetAttribute(config, this%tunit, default="", & - label=prefix//'tunit:', _RC) + label=prefix//'tunit:', _RC) + + call lgr%debug(' %a %a', 'input_template =', trim(this%input_template)) - !__ s2. find obsFile even if missing on disk and get array: this%t_alongtrack(:) ! call ESMF_VMGet(vm, mpiCommunicator=mpic, _RC) call MPI_COMM_RANK(mpic, irank, ierror) - + if (irank==0) & write(6,'(10(2x,a20,2x,a40,/))') & 'index_name_lon:', trim(this%index_name_lon), & @@ -547,42 +578,54 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc 'var_name_lon:', trim(this%var_name_lon), & 'var_name_lat:', trim(this%var_name_lat), & 'var_name_time:', trim(this%var_name_time), & - 'tunit:', trim(this%tunit) - - if (irank==0) then + 'tunit:', trim(this%tunit) + + if (irank==0) then call ESMF_TimeIntervalSet(Toff, h=0, m=0, s=0, _RC) call Find_M_files_for_currTime (currTime, & this%obsfile_start_time, this%obsfile_end_time, this%obsfile_interval, & this%epoch_frequency, this%input_template, M_file, this%filenames, & T_offset_in_file_content = Toff, _RC) this%M_file = M_file - write(6,'(10(2x,a20,2x,i40))') & + write(6,'(10(2x,a20,2x,i40))') & 'M_file:', M_file do i=1, M_file - write(6,'(10(2x,a20,2x,a))') & - 'filenames(i):', trim(this%filenames(i)) + write(6,'(10(2x,a14,i4,a2,2x,a))') & + 'filenames(', i, '):', trim(this%filenames(i)) end do + !------------------------------------------------------------ + ! QC for obs files: + ! + ! 1. redefine nstart to skip un-defined time value + ! 2. Scan_Start_Time = -9999, -9999, -9999, + ! :: eliminate this row of data + !------------------------------------------------------------ + + allocate(lon_true(0,0), lat_true(0,0), scanTime(0,0)) call read_M_files_4_swath (this%filenames(1:M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, _RC) + this%index_name_lon, this%index_name_lat, & + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=scanTime, & + Tfilter=.true., _RC) + nlon=nx nlat=ny - allocate(scanTime(nlon, nlat)) allocate(this%t_alongtrack(nlat)) + do j=1, nlat + this%t_alongtrack(j) = scanTime(1,j) + end do - call read_M_files_4_swath (this%filenames(1:M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_time=this%var_name_time, time=scanTime, _RC) + !!write(6,'(a)') 'this%t_alongtrack(::50)=' + !!write(6,'(5f20.2)') this%t_alongtrack(::50) - do j=1, nlat - this%t_alongtrack(j)= scanTime(1,j) - enddo nstart = 1 ! - ! redefine nstart to skip un-defined time value ! If the t_alongtrack contains undefined values, use this code - ! + ! x0 = this%t_alongtrack(1) x1 = 1.d16 if (x0 > x1) then @@ -590,7 +633,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc ! bisect backward finding the first index arr[n] < x1 klo=1 khi=nlat - max_iter = int( log( real(nlat) ) / log(2.d0) ) + 2 + max_iter = int( log( real(nlat) ) / log(2.d0) ) + 2 do i=1, max_iter k = (klo+khi)/2 if ( this%t_alongtrack(k) < x1 ) then @@ -607,7 +650,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%cell_across_swath = nlon this%cell_along_swath = nlat deallocate(scanTime) -!! write(6,*) 'this%t_alongtrack(j)=', this%t_alongtrack(::100) + ! P2. @@ -623,26 +666,32 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc j1= j0 + sec jx0= j0 jx1= j1 - call lgr%debug ('%a %i16 %i16', 'j0, j1 ', j0, j1) - this%epoch_index(1)= 1 this%epoch_index(2)= this%cell_across_swath - call bisect( this%t_alongtrack, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(this%cell_along_swath, ESMF_KIND_I8), rc=rc) - call bisect( this%t_alongtrack, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(this%cell_along_swath, ESMF_KIND_I8), rc=rc) + nend = this%cell_along_swath + call bisect( this%t_alongtrack, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call bisect( this%t_alongtrack, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + this%t_alongtrack(1), this%t_alongtrack(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) if (jt1==jt2) then _FAIL('Epoch Time is too small, empty swath grid is generated, increase Epoch') endif + jt1 = jt1 + 1 ! (x1,x2] design this%epoch_index(3)= jt1 this%epoch_index(4)= jt2 + _ASSERT( jt1 < jt2, 'Swath grid fail : epoch_index(3) > epoch_index(4)') Xdim = this%cell_across_swath Ydim = this%epoch_index(4) - this%epoch_index(3) + 1 call lgr%debug ('%a %i4 %i4', 'bisect for j0: rc, jt', rc, jt1) - call lgr%debug ('%a %i4 %i4', 'bisect for j1: rc, jt', rc, jt2) + call lgr%debug ('%a %i4 %i4', 'bisect for j1: rc, jt', rc, jt2) call lgr%debug ('%a %i4 %i4', 'Xdim, Ydim', Xdim, Ydim) call lgr%debug ('%a %i4 %i4 %i4 %i4', 'this%epoch_index(4)', & this%epoch_index(1), this%epoch_index(2), & @@ -651,7 +700,8 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%im_world = Xdim this%jm_world = Ydim end if - + + call MPI_bcast(this%M_file, 1, MPI_INTEGER, 0, mpic, ierror) do i=1, this%M_file call MPI_bcast(this%filenames(i), ESMF_MAXSTR, MPI_CHARACTER, 0, mpic, ierror) @@ -660,9 +710,10 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call MPI_bcast(this%im_world, 1, MPI_INTEGER, 0, mpic, ierror) call MPI_bcast(this%jm_world, 1, MPI_INTEGER, 0, mpic, ierror) call MPI_bcast(this%cell_across_swath, 1, MPI_INTEGER, 0, mpic, ierror) - call MPI_bcast(this%cell_along_swath, 1, MPI_INTEGER, 0, mpic, ierror) + call MPI_bcast(this%cell_along_swath, 1, MPI_INTEGER, 0, mpic, ierror) ! donot need to bcast this%along_track (root only) - + + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'IMS_FILE:', rc=status) if ( status == _SUCCESS ) then call get_ims_from_file(this%ims, trim(tmp),this%nx, _RC) @@ -678,9 +729,8 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc ! ims is set at here call this%check_and_fill_consistency(_RC) - _RETURN(_SUCCESS) - + 105 format (1x,a,2x,a) 106 format (1x,a,2x,10i8) @@ -698,11 +748,11 @@ subroutine get_multi_integer(values, label, rc) logical :: isPresent call ESMF_ConfigFindLabel(config, label=prefix//label, isPresent=isPresent, _RC) - + if (.not. isPresent) then _RETURN(_SUCCESS) end if - + ! First pass: count values n = 0 do @@ -721,9 +771,9 @@ subroutine get_multi_integer(values, label, rc) call ESMF_ConfigFindLabel(config, label=prefix//label,_RC) do i = 1, n call ESMF_ConfigGetAttribute(config, values(i), _RC) - write(6,*) 'values(i)=', values(i) + write(6,*) 'values(i)=', values(i) end do - + _RETURN(_SUCCESS) end subroutine get_multi_integer @@ -796,7 +846,7 @@ function to_string(this) result(string) end function to_string - + subroutine check_and_fill_consistency(this, unusable, rc) use MAPL_BaseMod, only: MAPL_DecomposeDim class (SwathGridFactory), intent(inout) :: this @@ -869,7 +919,7 @@ end subroutine verify end subroutine check_and_fill_consistency - + elemental subroutine set_with_default_integer(to, from, default) integer, intent(out) :: to integer, optional, intent(in) :: from @@ -936,7 +986,7 @@ elemental subroutine set_with_default_bounds(to, from, default) end subroutine set_with_default_bounds - + ! MAPL uses values in lon_array and lat_array only to determine the ! general positioning. Actual coordinates are then recomputed. ! This helps to avoid roundoff differences from slightly different @@ -967,7 +1017,7 @@ subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, real, parameter :: tiny = 1.e-4 _FAIL ('stop: not implemented: subroutine initialize_from_esmf_distGrid') - + _UNUSED_DUMMY(unusable) call ESMF_DistGridGet(dist_grid, dimCount=dim_count, tileCount=tile_count) @@ -1078,7 +1128,7 @@ function generate_grid_name(this) result(name) name = im_string // 'x' // jm_string end function generate_grid_name - + function check_decomposition(this,unusable,rc) result(can_decomp) class (SwathGridFactory), target, intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -1098,7 +1148,7 @@ function check_decomposition(this,unusable,rc) result(can_decomp) _RETURN(_SUCCESS) end function check_decomposition - + subroutine generate_newnxy(this,unusable,rc) use MAPL_BaseMod, only: MAPL_DecomposeDim class (SwathGridFactory), target, intent(inout) :: this @@ -1171,7 +1221,7 @@ subroutine append_metadata(this, metadata) character(len=ESMF_MAXSTR) :: key_lon character(len=ESMF_MAXSTR) :: key_lat - + ! Horizontal grid dimensions call metadata%add_dimension('lon', this%im_world) call metadata%add_dimension('lat', this%jm_world) @@ -1186,10 +1236,10 @@ subroutine append_metadata(this, metadata) call v%add_attribute('long_name', 'latitude') call v%add_attribute('units', 'degrees_north') call metadata%add_variable('lats', v) - + end subroutine append_metadata - + function get_grid_vars(this) result(vars) class (SwathGridFactory), intent(inout) :: this @@ -1197,7 +1247,7 @@ function get_grid_vars(this) result(vars) character(len=ESMF_MAXSTR) :: key_lon character(len=ESMF_MAXSTR) :: key_lat _UNUSED_DUMMY(this) - + !!key_lon=trim(this%var_name_lon) !!key_lat=trim(this%var_name_lat) vars = 'lon,lat' @@ -1300,7 +1350,7 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) integer:: irank, ierror integer :: status - type(ESMF_Time) :: T1, T2 + type(ESMF_Time) :: T1, T2 integer(ESMF_KIND_I8) :: i1, i2 real(ESMF_KIND_R8) :: iT1, iT2 integer(ESMF_KIND_I8) :: index1, index2 @@ -1315,7 +1365,7 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) ! xtrack xy_subset(1:2,1)=this%epoch_index(1:2) - ! atrack + ! atrack T1= interval(1) T2= interval(2) @@ -1337,24 +1387,24 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) call bisect( this%t_alongtrack, iT1, index1, n_LB=int(jlo, ESMF_KIND_I8), n_UB=int(jhi, ESMF_KIND_I8), rc=rc) call bisect( this%t_alongtrack, iT2, index2, n_LB=int(jlo, ESMF_KIND_I8), n_UB=int(jhi, ESMF_KIND_I8), rc=rc) - !! complex version + !! complex version !! ! (x1, x2] design in bisect !! if (index1==jlo-1) then !! je = index1 + 1 !! else !! je = index1 !! end if - !! xy_subset(1, 2) = je + !! xy_subset(1, 2) = je !! if (index2==jlo-1) then !! je = index2 + 1 !! else !! je = index2 - !! end if + !! end if !! xy_subset(2, 2) = je - ! simple version + ! simple version xy_subset(1, 2)=index1+1 ! atrack - xy_subset(2, 2)=index2 + xy_subset(2, 2)=index2 ! !- relative @@ -1364,18 +1414,18 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) end if call MPI_bcast(xy_subset, 4, MPI_INTEGER, 0, mpic, ierror) - + _RETURN(_SUCCESS) end subroutine get_xy_subset - + subroutine destroy(this, rc) class(SwathGridFactory), intent(inout) :: this integer, optional, intent(out) :: rc - integer :: i + integer :: i return end subroutine destroy - + ! here grid == external_grid ! because this%grid is protected in AbstractGridFactory @@ -1387,56 +1437,68 @@ subroutine get_obs_time(this, grid, obs_time, rc) integer, optional, intent(out) :: rc integer :: status - integer :: i_1, i_n, j_1, j_n ! regional array bounds - - !! shared mem real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) - real, pointer :: centers(:,:) - real, allocatable :: centers_full(:,:) - + real(kind=ESMF_KIND_R8), pointer :: centers(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lat_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_time(:,:) + integer :: i, j, k - integer :: Xdim, Ydim - integer :: Xdim_full, Ydim_full + integer :: Xdim, Ydim, count integer :: nx, ny - integer :: IM_WORLD, JM_WORLD + integer :: i_1, i_n, j_1, j_n ! regional array bounds + ! debug + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: mpic - !- shared mem case in MPI - ! + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) + Xdim=this%im_world Ydim=this%jm_world - Xdim_full=this%cell_across_swath - Ydim_full=this%cell_along_swath + count=Xdim*Ydim call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_time,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) - - ! read Time and set - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) + if (mapl_am_i_root()) then + allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & this%index_name_lon, this%index_name_lat, & - var_name_time=this%var_name_time, time=centers_full, _RC) - !!call get_v2d_netcdf(this%grid_file_name, time_name, centers_full, Xdim_full, Ydim_full) + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=time_true, & + Tfilter=.true., _RC) k=0 do j=this%epoch_index(3), this%epoch_index(4) k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) + arr_time(1:Xdim, k) = time_true(1:Xdim, j) enddo - deallocate (centers_full) + deallocate( lon_true, lat_true, time_true ) + +! write(6,*) 'in root, time' +! write(6,'(11x,100E12.5)') arr_time(::5,189) end if call MAPL_SyncSharedMemory(_RC) + call MAPL_BcastShared (VM, data=arr_time, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + +! write(6,'(2x,a,2x,i5,4x,100E12.5)') 'PET, time', mypet, arr_time(::5,189) +! call MPI_Barrier(mpic, status) + !(Xdim, Ydim) - obs_time = centers(i_1:i_n,j_1:j_n) + obs_time = arr_time(i_1:i_n,j_1:j_n) if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(centers,_RC) + call MAPL_DeAllocNodeArray(arr_time,_RC) else - deallocate(centers) - end if + deallocate(arr_time) + end if _RETURN(_SUCCESS) end subroutine get_obs_time diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 7d3f8fc81746..1bcbc57ea3ce 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -8,9 +8,14 @@ module MAPL_XYGridFactoryMod use MAPL_ExceptionHandling use MAPL_ShmemMod use MAPL_Constants + use MAPL_CommsMod + use MAPL_BaseMod use ESMF use pFIO use NetCDF + ! use Plain_netCDF_Time, only : get_ncfile_dimension + use Plain_netCDF_Time + use MAPL_ObsUtilMod, only : ABI_XY_2_lonlat use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -36,14 +41,25 @@ module MAPL_XYGridFactoryMod logical :: has_corners logical :: initialized_from_metadata = .false. + + character(len=ESMF_MAXSTR) :: index_name_x + character(len=ESMF_MAXSTR) :: index_name_y + character(len=ESMF_MAXSTR) :: var_name_x + character(len=ESMF_MAXSTR) :: var_name_y + character(len=ESMF_MAXSTR) :: var_name_proj + character(len=ESMF_MAXSTR) :: att_name_proj + + integer :: xdim_true + integer :: ydim_true + integer :: thin_factor contains procedure :: make_new_grid procedure :: create_basic_grid procedure :: add_horz_coordinates_from_file + procedure :: add_horz_coordinates_from_ABIfile procedure :: init_halo procedure :: halo - procedure :: initialize_from_file_metadata procedure :: initialize_from_config_with_prefix procedure :: initialize_from_esmf_distGrid @@ -65,6 +81,7 @@ module MAPL_XYGridFactoryMod procedure :: decomps_are_equal procedure :: physical_params_are_equal procedure :: file_has_corners + procedure :: add_mask end type XYGridFactory character(len=*), parameter :: MOD_NAME = 'MAPL_XYGridFactory::' @@ -101,7 +118,6 @@ function XYGridFactory_from_parameters(unusable, grid_file_name, grid_name, & integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'XYGridFactory_from_parameters' - if (present(unusable)) print*,shape(unusable) call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) @@ -113,12 +129,8 @@ function XYGridFactory_from_parameters(unusable, grid_file_name, grid_name, & call set_with_default(factory%jm_world, jm_world, MAPL_UNDEFINED_INTEGER) call set_with_default(factory%lm, lm, MAPL_UNDEFINED_INTEGER) - - - call factory%check_and_fill_consistency(rc=status) _VERIFY(status) - _RETURN(_SUCCESS) end function XYGridFactory_from_parameters @@ -135,11 +147,13 @@ function make_new_grid(this, unusable, rc) result(grid) _UNUSED_DUMMY(unusable) - grid = this%create_basic_grid(rc=status) - _VERIFY(status) - - call this%add_horz_coordinates_from_file(grid, rc=status) - _VERIFY(status) + grid = this%create_basic_grid(_RC) + if ( index(trim(adjustl(this%grid_name)), 'ABI') == 0 ) then + call this%add_horz_coordinates_from_file(grid, _RC) + else + call this%add_horz_coordinates_from_ABIfile(grid, _RC) + end if + call this%add_mask(grid,_RC) _RETURN(_SUCCESS) @@ -167,8 +181,7 @@ function create_basic_grid(this, unusable, rc) result(grid) gridEdgeUWidth=[0,1], & coordDep1=[1,2], & coordDep2=[1,2], & - coordSys=ESMF_COORDSYS_SPH_RAD, rc=status) - _VERIFY(status) + coordSys=ESMF_COORDSYS_SPH_RAD, _RC) ! Allocate coords at default stagger location call ESMF_GridAddCoord(grid, rc=status) @@ -180,16 +193,15 @@ function create_basic_grid(this, unusable, rc) result(grid) _VERIFY(status) if (this%lm /= MAPL_UNDEFINED_INTEGER) then - call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, rc=status) - _VERIFY(status) + call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, _RC) end if - call ESMF_AttributeSet(grid, 'GridType', 'XY', rc=status) - _VERIFY(status) + call ESMF_AttributeSet(grid, 'GridType', 'XY', _RC) _RETURN(_SUCCESS) end function create_basic_grid + subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) use MAPL_BaseMod, only: MAPL_grid_interior, MAPL_gridget use MAPL_CommsMod @@ -215,7 +227,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _UNUSED_DUMMY(unusable) - lon_center_name = "lons" lat_center_name = "lats" lon_corner_name = "corner_lons" @@ -253,7 +264,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,centers) _VERIFY(status) - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -269,7 +280,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,centers) _VERIFY(status) - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -296,7 +307,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,corners) _VERIFY(status) - corners=corners*MAPL_DEGREES_TO_RADIANS_R8 + where(corners /= MAPL_UNDEF) corners=corners*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -312,7 +323,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,corners) _VERIFY(status) - corners=corners*MAPL_DEGREES_TO_RADIANS_R8 + where(corners /= MAPL_UNDEF) corners=corners*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -338,6 +349,86 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) end subroutine add_horz_coordinates_from_file + + subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) + use MAPL_CommsMod + use MAPL_IOMod + use MAPL_Constants + class (XYGridFactory), intent(in) :: this + type (ESMF_Grid), intent(inout) :: grid + class (KeywordEnforcer), optional, intent(in) :: unusable + integer, optional, intent(out) :: rc + integer :: status + + type(ESMF_VM) :: vm + integer :: i, j + integer :: ix, jx + integer :: i_1, i_n, j_1, j_n + real(REAL64), pointer :: fptr_x(:,:) ! lon + real(REAL64), pointer :: fptr_y(:,:) ! lat + real(REAL64), pointer :: x(:) + real(REAL64), pointer :: y(:) + real(REAL64), pointer :: lambda0(:) + real(REAL64) :: lambda0_deg + real(REAL64) :: x0, y0 + real(REAL64) :: lam_sat + character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att + + _UNUSED_DUMMY(unusable) + + call MAPL_Grid_Interior (grid, i_1, i_n, j_1, j_n) + call MAPL_AllocateShared(x,[this%Xdim_true],transroot=.true.,_RC) + call MAPL_AllocateShared(y,[this%Ydim_true],transroot=.true.,_RC) + call MAPL_AllocateShared(lambda0,[1],transroot=.true.,_RC) + call MAPL_SyncSharedMemory(_RC) + + if (mapl_am_i_root()) then + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) + call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) + lambda0 = lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + end if + call MAPL_SyncSharedMemory(_RC) + + call ESMF_VMGetCurrent(vm, _RC) + call MAPL_BcastShared (vm, data=x, N=this%Xdim_true, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=y, N=this%Ydim_true, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=lambda0, N=1, Root=MAPL_ROOT, RootOnly=.false., _RC) + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr_x, _RC) + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr_y, _RC) + lam_sat = lambda0(1) + do i = i_1, i_n + ix = i - i_1 + 1 + do j= j_1, j_n + jx = j - j_1 + 1 + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, fptr_x(ix, jx), fptr_y(ix, jx) ) + end do + end do + call MAPL_SyncSharedMemory(_RC) + + if(MAPL_ShmInitialized) then + call MAPL_DeAllocNodeArray(x,_RC) + call MAPL_DeAllocNodeArray(y,_RC) + else + deallocate(x) + deallocate(y) + end if + + _RETURN(_SUCCESS) + + end subroutine add_horz_coordinates_from_ABIfile + + subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_file_coordinates, rc) use MAPL_KeywordEnforcerMod use MAPL_BaseMod, only: MAPL_DecomposeDim @@ -389,27 +480,50 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer :: status character(len=*), parameter :: Iam = MOD_NAME//'make_geos_grid_from_config' character(len=ESMF_MAXSTR) :: tmp + integer :: n1, n2 + integer :: arr(2) + type(ESMF_VM) :: vm if (present(unusable)) print*,shape(unusable) - call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT) + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT, _RC) this%grid_name = trim(tmp) - - call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDSPEC:', rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRID_FILENAME:', default='', _RC) this%grid_file_name = trim(tmp) - call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%im_world, label=prefix//'IM_WORLD:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%jm_world, label=prefix//'JM_WORLD:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER) + call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER, _RC) + call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER, _RC) + call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER, _RC) + + call ESMF_ConfigGetAttribute(config, this%index_name_x, label=prefix//'index_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, this%index_name_y, label=prefix//'index_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_x, label=prefix//'var_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_y, label=prefix//'var_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_proj,label=prefix//'var_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, this%att_name_proj,label=prefix//'att_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, this%thin_factor, label=prefix//'thin_factor:', default=1, _RC) + + if (mapl_am_i_root()) then + call get_ncfile_dimension(this%grid_file_name, nlon=n1, nlat=n2, & + key_lon=this%index_name_x, key_lat=this%index_name_y, _RC) + arr(1)=n1 + arr(2)=n2 + end if + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMBroadcast (vm, arr, 2, 0, _RC) + ! + ! use thin_factor to reduce regridding matrix size + ! + this%xdim_true = arr(1) + this%ydim_true = arr(2) + this%im_world = arr(1) / this%thin_factor + this%jm_world = arr(2) / this%thin_factor call this%check_and_fill_consistency(rc=status) _RETURN(_SUCCESS) - contains + contains subroutine get_multi_integer(values, label, rc) integer, allocatable, intent(out) :: values(:) @@ -483,8 +597,8 @@ subroutine check_and_fill_consistency(this, unusable, rc) this%grid_name = MAPL_GRID_NAME_DEFAULT end if ! local extents - call verify(this%nx, this%im_world, this%ims, rc=status) - call verify(this%ny, this%jm_world, this%jms, rc=status) + call verify(this%nx, this%im_world, this%ims, _RC) + call verify(this%ny, this%jm_world, this%jms, _RC) call this%file_has_corners(_RC) _RETURN(_SUCCESS) @@ -515,13 +629,11 @@ subroutine verify(n, m_world, ms, rc) end if else - _ASSERT(n /= MAPL_UNDEFINED_INTEGER,"needs message") _ASSERT(m_world /= MAPL_UNDEFINED_INTEGER,"needs message") allocate(ms(n), stat=status) _VERIFY(status) call MAPL_DecomposeDim(m_world, ms, n) - end if _RETURN(_SUCCESS) @@ -894,4 +1006,38 @@ subroutine file_has_corners(this,rc) _RETURN(_SUCCESS) end subroutine + subroutine add_mask(this,grid,rc) + class(XYGridFactory), intent(in) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, intent(out), optional :: rc + + integer(ESMF_KIND_I4), pointer :: mask(:,:) + real(ESMF_KIND_R8), pointer :: fptr(:,:) + integer :: status + type(ESMF_VM) :: vm + integer :: has_undef, local_has_undef + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + local_has_undef = 0 + if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 + + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + if (any(fptr == MAPL_UNDEF)) local_has_undef = local_has_undef + 1 + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) + _RETURN_IF(has_undef == 0) + + call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER,itemflag=ESMF_GRIDITEM_MASK,_RC) + call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & + itemflag=ESMF_GRIDITEM_MASK,farrayPtr=mask,_RC) + + mask = MAPL_MASK_IN + where(fptr==MAPL_UNDEF) mask = MAPL_MASK_OUT + + _RETURN(_SUCCESS) + end subroutine add_mask + end module MAPL_XYGridFactoryMod diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index be20b3d76bb1..8dcc1d7b6c6b 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -25,11 +25,10 @@ module Plain_netCDF_Time ! use MAPL_CommsMod use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_c_binding, only: C_INT implicit none public - integer, parameter :: NUM_DIM = 2 - interface convert_time_nc2esmf procedure :: time_nc_int_2_esmf end interface convert_time_nc2esmf @@ -117,7 +116,11 @@ subroutine get_attribute_from_group(filename, group_name, var_name, attr_name, a character(len=100) :: str2 call check_nc_status(nf90_open(fileName, NF90_NOWRITE, ncid2), _RC) - call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + if (group_name/='') then + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + else + ncid = ncid2 + end if call check_nc_status(nf90_inq_varid(ncid, var_name, varid), _RC) call check_nc_status(nf90_inquire_attribute(ncid, varid, attr_name, xtype, len=len), _RC) c_ncid= ncid @@ -234,6 +237,106 @@ subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name, rc) end subroutine get_v1d_netcdf_R8 + subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_value, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(REAL64), intent(inout) :: array(:) + character(len=*), optional, intent(in) :: att_name + real(REAL64), optional, intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name + integer, optional, intent(out) :: rc + + integer :: status, iret + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + real(REAL32) :: scale_factor, add_offset + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid + if(present(group_name)) then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! mod + ncid = ncid_grp + end if + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) + call check_nc_status(nf90_get_var(ncid, varid, array), _RC) + + iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) + if(iret .eq. 0) array = array * scale_factor + ! + iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) + if(iret .eq. 0) array = array + add_offset + + if(present(att_name)) then + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + end if + + call check_nc_status(nf90_close(ncid_sv), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_v1d_netcdf_R8_complete + + + subroutine get_att_real_netcdf(filename, varname, att_name, att_value, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(REAL64), intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name + integer, optional, intent(out) :: rc + integer :: status + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid + if(present(group_name)) then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp + end if + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + call check_nc_status(nf90_close(ncid_sv), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_att_real_netcdf + + subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name + integer, optional, intent(out) :: rc + integer :: status + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid + if(present(group_name)) then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp + end if + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + call check_nc_status(nf90_close(ncid_sv), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_att_char_netcdf + + subroutine check_nc_status(status, rc) use netcdf implicit none @@ -241,7 +344,6 @@ subroutine check_nc_status(status, rc) integer, intent(out), optional :: rc _ASSERT(status == nf90_noerr, 'netCDF error: '//trim(nf90_strerror(status))) - _RETURN(_SUCCESS) end subroutine check_nc_status @@ -287,10 +389,20 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) type(ESMF_Time) :: time0 type(ESMF_TimeInterval) :: dt + character(len=ESMF_MAXSTR) :: STR1 + + n=0 call parse_timeunit(tunit, n, time0, dt, _RC) dt = time - time0 +! ! test +! write(6, '(2x,a,2x,a)') 'tunit=', trim(tunit) +! call ESMF_TimeGet(time, timestring=STR1, _RC) +! write(6, '(2x,a,2x,a)') 'time=', trim(STR1) +! call ESMF_TimeGet(time0, timestring=STR1, _RC) +! write(6, '(2x,a,2x,a)') 'time0=', trim(STR1) + ! assume unit is second ! call ESMF_TimeIntervalGet(dt, s_i8=n, _RC) @@ -300,6 +412,10 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) end subroutine time_esmf_2_nc_int + ! + ! n sec after tunit + ! t0 = since [ xxxx-xx-xx ] + ! dt = n sec subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) use ESMF implicit none @@ -329,7 +445,7 @@ subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) isec=n gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& calendar=gregorianCalendar, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, _RC) @@ -363,11 +479,14 @@ subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec +! write(6,*) 'y, c1, m, c1, d', y, c1, m, c1, d +! write(6,*) 'hour, c1, min, c1, sec', hour, c1, min, c1, sec + _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") isec=n gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& calendar=gregorianCalendar, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, _RC) @@ -451,7 +570,7 @@ subroutine bisect_find_LB_R8_I8(xa, x, n, n_LB, n_UB, rc) if(present(n_LB)) LB=max(LB, n_LB) if(present(n_UB)) UB=min(UB, n_UB) klo=LB; khi=UB; dk=1 - + if ( xa(LB ) > xa(UB) ) then klo= UB khi= LB @@ -673,7 +792,7 @@ function matches( string, substring ) RETURN end function matches - + subroutine split_string_by_space (string_in, length_mx, & mxseg, nseg, str_piece, jstatus) integer, intent (in) :: length_mx diff --git a/base/tests/CMakeLists.txt b/base/tests/CMakeLists.txt index 46577909e502..d246076f242f 100644 --- a/base/tests/CMakeLists.txt +++ b/base/tests/CMakeLists.txt @@ -33,7 +33,7 @@ set (SRCS # MAPL_Initialize.F90 # ) #target_link_libraries (base_extras MAPL.shared MAPL.pfunit -# esmf NetCDF::NetCDF_Fortran) +# ESMF::ESMF NetCDF::NetCDF_Fortran) add_pfunit_ctest(MAPL.base.tests TEST_SOURCES ${TEST_SRCS} diff --git a/benchmarks/io/checkpoint_simulator/CMakeLists.txt b/benchmarks/io/checkpoint_simulator/CMakeLists.txt index 718d3b706d4e..4b08c60fffd6 100644 --- a/benchmarks/io/checkpoint_simulator/CMakeLists.txt +++ b/benchmarks/io/checkpoint_simulator/CMakeLists.txt @@ -1,12 +1,14 @@ set(exe checkpoint_simulator.x) +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/checkpoint_simulator) ecbuild_add_executable ( TARGET ${exe} - SOURCES checkpoint_simulator.F90 + SOURCES checkpoint_simulator.F90 DEFINITIONS USE_MPI) -target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse esmf ) +target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse ESMF::ESMF ) target_include_directories (${exe} PUBLIC $) +set_target_properties (${exe} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/combo/CMakeLists.txt b/benchmarks/io/combo/CMakeLists.txt index c0d2aa99a884..99a92e1b46a6 100644 --- a/benchmarks/io/combo/CMakeLists.txt +++ b/benchmarks/io/combo/CMakeLists.txt @@ -1,4 +1,5 @@ set(exe combo.x) +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/combo) ecbuild_add_executable ( TARGET ${exe} @@ -7,6 +8,7 @@ ecbuild_add_executable ( target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (${exe} PUBLIC $) +set_target_properties (${exe} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/gatherv/CMakeLists.txt b/benchmarks/io/gatherv/CMakeLists.txt index 5510ff1c3b33..d6072fb82823 100644 --- a/benchmarks/io/gatherv/CMakeLists.txt +++ b/benchmarks/io/gatherv/CMakeLists.txt @@ -1,3 +1,5 @@ +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/gatherv) + ecbuild_add_executable ( TARGET gatherv.x SOURCES GathervKernel.F90 GathervSpec.F90 driver.F90 @@ -5,6 +7,7 @@ ecbuild_add_executable ( target_link_libraries (gatherv.x PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (gatherv.x PUBLIC $) +set_target_properties (gatherv.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/raw_bw/CMakeLists.txt b/benchmarks/io/raw_bw/CMakeLists.txt index 911a836a7ea5..7477ddf6e43f 100644 --- a/benchmarks/io/raw_bw/CMakeLists.txt +++ b/benchmarks/io/raw_bw/CMakeLists.txt @@ -1,3 +1,5 @@ +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/raw_bw) + ecbuild_add_executable ( TARGET raw_bw.x SOURCES BW_Benchmark.F90 BW_BenchmarkSpec.F90 driver.F90 @@ -5,6 +7,7 @@ ecbuild_add_executable ( target_link_libraries (raw_bw.x PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (raw_bw.x PUBLIC $) +set_target_properties (raw_bw.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake index 23efbb31d078..eabba677d3b6 100644 --- a/cmake/FindESMF.cmake +++ b/cmake/FindESMF.cmake @@ -109,6 +109,11 @@ if(EXISTS ${ESMFMKFILE}) endif() endif() + # Add target alias to facilitate unambiguous linking + if(NOT TARGET ESMF::ESMF) + add_library(ESMF::ESMF ALIAS ESMF) + endif() + # Add ESMF include directories set(ESMF_INCLUDE_DIRECTORIES "") separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) diff --git a/components.yaml b/components.yaml index e0bbd84af99c..4c63d816dee8 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.36.0 + tag: v3.40.0 develop: develop ecbuild: diff --git a/docs/tutorial/driver_app/Example_Driver.F90 b/docs/tutorial/driver_app/Example_Driver.F90 index f974d002a624..b967506b94c0 100644 --- a/docs/tutorial/driver_app/Example_Driver.F90 +++ b/docs/tutorial/driver_app/Example_Driver.F90 @@ -5,6 +5,7 @@ program Example_Driver use MPI use MAPL + use mapl_CapOptionsMod, only: MAPL_CapOptions implicit none type (MAPL_Cap) :: cap diff --git a/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt b/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt index 4ae20760f332..8422b3a79540 100644 --- a/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt +++ b/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt @@ -6,7 +6,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) diff --git a/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt b/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt index cc348414e1aa..0e74c76742a1 100644 --- a/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt +++ b/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt b/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt index 1dfc4cd25bae..d912da16f28d 100644 --- a/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt +++ b/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt b/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt index ec9acc547f90..e2ae84142283 100644 --- a/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt +++ b/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt index c8e06933c33b..c9c4299b76bd 100644 --- a/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt index 4274f2448dc0..b5da305f8e82 100644 --- a/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt index d3f0ea92b3c7..66b39a86a6b3 100644 --- a/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/field_utils/CMakeLists.txt b/field_utils/CMakeLists.txt index 68381a757c12..136d8cdb2dd0 100644 --- a/field_utils/CMakeLists.txt +++ b/field_utils/CMakeLists.txt @@ -30,8 +30,8 @@ esma_add_library(${this} target_include_directories (${this} PUBLIC $) -#target_link_libraries (${this} PUBLIC esmf NetCDF::NetCDF_Fortran) -target_link_libraries (${this} PUBLIC esmf) +#target_link_libraries (${this} PUBLIC ESMF::ESMF NetCDF::NetCDF_Fortran) +target_link_libraries (${this} PUBLIC ESMF::ESMF) if (PFUNIT_FOUND) # Turning off until test with GNU can be fixed diff --git a/field_utils/FieldPointerUtilities.F90 b/field_utils/FieldPointerUtilities.F90 index b1a22258fcc8..8773ccd83436 100644 --- a/field_utils/FieldPointerUtilities.F90 +++ b/field_utils/FieldPointerUtilities.F90 @@ -3,7 +3,7 @@ module MAPL_FieldPointerUtilities use ESMF use MAPL_ExceptionHandling - use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc implicit none private @@ -483,14 +483,14 @@ logical function are_broadcast_conformable(x, y, rc) result(conformable) integer, dimension(:), allocatable :: count_x, count_y integer :: status logical :: normal_conformable - + conformable = .false. ! this should really used the geom and ungridded dims ! for now we will do this until we have a geom agnostic stuff worked out... ! the ideal algorithm would be if geom == geom and input does not have ungridded ! and thing we are copying to does, then we are "conformable" normal_conformable = FIeldsAreConformable(x,y,_RC) - + if (normal_conformable) then conformable = .true. _RETURN(_SUCCESS) @@ -842,7 +842,7 @@ subroutine MAPL_FieldGetLocalElementCount(field,local_count,rc) else _FAIL("Unsupported rank") end if - else + else _FAIL("Unsupported type") end if _RETURN(_SUCCESS) @@ -871,7 +871,7 @@ subroutine GetFieldsUndef_r4(fields,undef_values,rc) integer :: status, i logical :: isPresent - + allocate(undef_values(size(fields))) do i =1,size(fields) call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) @@ -888,7 +888,7 @@ subroutine GetFieldsUndef_r8(fields,undef_values,rc) integer :: status, i logical :: isPresent - + allocate(undef_values(size(fields))) do i =1,size(fields) call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index 6830413e7bbb..b3302c0401ce 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -8,16 +8,21 @@ module Test_FieldArithmetic use MAPL_FieldUtilities use MAPL_FieldPointerUtilities use ESMF - use funit + use pfunit use MAPL_ExceptionHandling implicit none + real(kind=ESMF_KIND_R4), parameter :: ADD_R4 = 100.0 + real(kind=ESMF_KIND_R8), parameter :: ADD_R8 = 100.0 + contains + ! Making the fields should be done in the tests themselves so because + ! of the npes argument. @Before - subroutine set_up_data() - implicit none + subroutine set_up_data(this) + class(MpiTestMethod), intent(inout) :: this integer :: status, rc @@ -30,14 +35,10 @@ contains allocate(y8array, source=R8_ARRAY_DEFAULT) y4array = y4array + ADD_R4 y8array = y8array + ADD_R8 - XR4 = mk_field(R4_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4', _RC) - YR4 = mk_field(y4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4', _RC) - XR8 = mk_field(R8_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) - YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + XR4 = mk_field(R4_ARRAY_DEFAULT, name = 'XR4', _RC) + YR4 = mk_field(y4array, name = 'YR4', _RC) + XR8 = mk_field(R8_ARRAY_DEFAULT, name = 'XR8', _RC) + YR8 = mk_field(y8array, name = 'YR8', _RC) call ESMF_AttributeSet(xr4,name="missing_value",value=undef,_RC) call ESMF_AttributeSet(xr8,name="missing_value",value=undef,_RC) call ESMF_AttributeSet(yr4,name="missing_value",value=undef,_RC) @@ -45,29 +46,39 @@ contains end subroutine set_up_data - @Test - subroutine test_FieldAddR4() + @after + subroutine teardown(this) + class(MpiTestMethod), intent(inout) :: this + end subroutine teardown + + @Test(npes=[4]) + subroutine test_FieldAddR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) integer :: status, rc + real(kind=ESMF_KIND_R4), allocatable :: y4array(:,:) - x = XR4 - y = YR4 + allocate(y4array, source=R4_ARRAY_DEFAULT) + x = mk_r4field(R4_ARRAY_DEFAULT, 'XR4', _RC) + y = mk_r4field(y4array, 'YR4', _RC) call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) x_ptr = 2.0 - y_ptr = 3.0 + y_ptr = 3.0 result_array = x_ptr result_array = 5.0 call FieldAdd(y, x, y, _RC) @assertEqual(y_ptr, result_array) + end subroutine test_FieldAddR4 - @Test - subroutine test_FieldAddR4_missing + @Test(npes=[4]) + subroutine test_FieldAddR4_missing(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) @@ -87,16 +98,19 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4_missing - @Test - subroutine test_FieldAddR8() + @Test(npes=[4]) + subroutine test_FieldAddR8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:), y_ptr(:,:) real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) integer :: status, rc + real(kind=ESMF_KIND_R8), allocatable :: y8array(:,:) - x = XR8 - y = YR8 + allocate(y8array, source=R8_ARRAY_DEFAULT) + x = mk_r8field(R8_ARRAY_DEFAULT, 'XR8', _RC) + y = mk_r8field(y8array, 'YR8', _RC) call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) @@ -108,8 +122,9 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR8 - @Test - subroutine test_FieldPowR4() + @Test(npes=[4]) + subroutine test_FieldPowR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) @@ -127,8 +142,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR4 - @Test - subroutine test_FieldPowR8() + @Test(npes=[4]) + subroutine test_FieldPowR8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) @@ -146,8 +162,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR8 - @Test - subroutine test_FieldSinR4() + @Test(npes=[4]) + subroutine test_FieldSinR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) @@ -163,8 +180,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldSinR4 - @Test - subroutine test_FieldNegR4() + @Test(npes=[4]) + subroutine test_FieldNegR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index d289d2e0970c..f17f0c9b330c 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -6,7 +6,7 @@ module Test_FieldBLAS use field_utils_setup use MAPL_FieldPointerUtilities use ESMF - use funit + use pfunit use MAPL_ExceptionHandling implicit none @@ -14,8 +14,8 @@ module Test_FieldBLAS contains @Before - subroutine set_up_data() - implicit none + subroutine set_up_data(this) + class(MpiTestMethod), intent(inout) :: this integer :: status, rc @@ -28,24 +28,24 @@ contains allocate(y8array, source=R8_ARRAY_DEFAULT) y4array = y4array + ADD_R4 y8array = y8array + ADD_R8 - XR4 = mk_field(R4_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4', _RC) - YR4 = mk_field(y4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4', _RC) - XR8 = mk_field(R8_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) - YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) - XR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) - YR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) + XR4 = mk_field(R4_ARRAY_DEFAULT, name = 'XR4', _RC) + YR4 = mk_field(y4array, name = 'YR4', _RC) + XR8 = mk_field(R8_ARRAY_DEFAULT, name = 'XR8', _RC) + YR8 = mk_field(y8array, name = 'YR8', _RC) + XR4_3D = mk_field_r4_ungrid(name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) + YR4_3D = mk_field_r4_ungrid(name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) end subroutine set_up_data - @Test + @after + subroutine teardown(this) + class(MpiTestMethod), intent(inout) :: this + end subroutine teardown + + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL32) - subroutine test_FieldCOPY_R4() + subroutine test_FieldCOPY_R4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr @@ -61,9 +61,10 @@ contains end subroutine test_FieldCOPY_R4 - @Test + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL64) - subroutine test_FieldCOPY_R8() + subroutine test_FieldCOPY_R8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -79,9 +80,10 @@ contains end subroutine test_FieldCOPY_R8 - @Test + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL32 -> REAL64) - subroutine test_FieldCOPY_R4R8() + subroutine test_FieldCOPY_R4R8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr @@ -97,9 +99,10 @@ contains end subroutine test_FieldCOPY_R4R8 - @Test + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL64 -> REAL32) - subroutine test_FieldCOPY_R8R4() + subroutine test_FieldCOPY_R8R4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -117,9 +120,10 @@ contains end subroutine test_FieldCOPY_R8R4 - @Test + @Test(npes=[4]) ! Basic test of FieldSCAL subroutine (REAL32) - subroutine test_FieldSCAL_R4() + subroutine test_FieldSCAL_R4(this) + class(MpiTestMethod), intent(inout) :: this real(kind=ESMF_KIND_R4), parameter :: a = 2.0 type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), dimension(:,:), allocatable :: x_array @@ -135,10 +139,11 @@ contains end subroutine test_FieldSCAL_R4 - @Test + @Test(npes=[4]) ! Basic test of FieldSCAL subroutine (REAL64) - subroutine test_FieldSCAL_R8() - real(kind=ESMF_KIND_R8), parameter :: a = 2.0 + subroutine test_FieldSCAL_R8(this) + class(MpiTestMethod), intent(inout) :: this + real(kind=ESMF_KIND_R8), parameter :: a = 2.0 type(ESMF_Field) :: x real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -153,9 +158,10 @@ contains end subroutine test_FieldSCAL_R8 - @Test + @Test(npes=[4]) ! - subroutine test_FieldAXPY_R4() + subroutine test_FieldAXPY_R4(this) + class(MpiTestMethod), intent(inout) :: this real(kind=ESMF_KIND_R4), parameter :: a = 2.0 type(ESMF_Field) :: x type(ESMF_Field) :: y @@ -178,10 +184,11 @@ contains end subroutine test_FieldAXPY_R4 - @Test + @Test(npes=[4]) ! - subroutine test_FieldAXPY_R8() - real(kind=ESMF_KIND_R8), parameter :: a = 2.0 + subroutine test_FieldAXPY_R8(this) + class(MpiTestMethod), intent(inout) :: this + real(kind=ESMF_KIND_R8), parameter :: a = 2.0 type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array @@ -199,12 +206,12 @@ contains call FieldAXPY(a, x, y, _RC) call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) -! @assertEqual(y_ptr, a*x_array+y_array) !wdb fixme Temporarily disabled end subroutine test_FieldAXPY_R8 - @Test - subroutine test_FieldGetLocalElementCount() + @Test(npes=[4]) + subroutine test_FieldGetLocalElementCount(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x integer :: rank integer, allocatable :: expected_count(:) @@ -217,13 +224,13 @@ contains call ESMF_FieldGet(x, localElementCount=expected_count, _RC) actual_count = FieldGetLocalElementCount(x, _RC) @assertEqual(actual_count, expected_count) - if(allocated(expected_count)) deallocate(expected_count) end subroutine test_FieldGetLocalElementCount - @Test + @Test(npes=[4]) ! - subroutine test_FieldGetLocalSize() + subroutine test_FieldGetLocalSize(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x integer :: status, rc integer :: rank @@ -242,14 +249,14 @@ contains end subroutine test_FieldGetLocalSize - @Test + @Test(npes=[4]) ! Test getting the c_ptr for a field !wdb fixme Should test more extensively for different ranks !wdb fixme Should test for ESMF_KIND_I4 and ESMF_KIND_I8 !wdb fixme Should check c_cptr from tested method against independent test - - subroutine test_FieldGetCptr() - type(ESMF_Field) :: x + subroutine test_FieldGetCptr(this) + class(MpiTestMethod), intent(inout) :: this + type(ESMF_Field) :: x type(c_ptr) :: cptr integer :: status, rc @@ -260,9 +267,10 @@ contains end subroutine test_FieldGetCptr - @Test + @Test(npes=[4]) !wdb fixme Probably should test for non-conformable fields - subroutine test_FieldsAreConformableR4() + subroutine test_FieldsAreConformableR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc logical :: are_conformable @@ -276,9 +284,10 @@ contains end subroutine test_FieldsAreConformableR4 !wdb fixme Probably should test for non-conformable fields - @Test - subroutine test_FieldsAreConformableR8() - type(ESMF_Field) :: x, y + @Test(npes=[4]) + subroutine test_FieldsAreConformableR8(this) + class(MpiTestMethod), intent(inout) :: this + type(ESMF_Field) :: x, y integer :: status, rc logical :: are_conformable @@ -290,9 +299,10 @@ contains end subroutine test_FieldsAreConformableR8 - @Test + @Test(npes=[4]) ! - subroutine test_FieldsAreSameTypeKind() + subroutine test_FieldsAreSameTypeKind(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc logical :: are_same_typekind @@ -317,10 +327,10 @@ contains end subroutine test_FieldsAreSameTypeKind -!wdb fixme Enable assertEqual - @Test - subroutine test_FieldConvertPrec_R4R8() - integer, parameter :: NROWS = 4 + @Test(npes=[4]) + subroutine test_FieldConvertPrec_R4R8(this) + class(MpiTestMethod), intent(inout) :: this + integer, parameter :: NROWS = 2 integer, parameter :: NCOLS = NROWS type(ESMF_Field) :: r4_field, r8_field real(kind=ESMF_KIND_R4) :: r4_data(NROWS,NCOLS) @@ -332,20 +342,17 @@ contains call initialize_array(r4_data, 0.0, 1.0) r8_data = 0.0 r8_converted = r4_data - r4_field = mk_field(r4_data, regDecomp = REG_DECOMP_DEFAULT, minIndex = [1, 1], & - maxIndex = [NROWS, NCOLS], indexflag = INDEX_FLAG_DEFAULT, & - name = 'XR4', _RC) - r8_field = mk_field(r8_data, regDecomp = REG_DECOMP_DEFAULT, minIndex = [1, 1], & - maxIndex = [NROWS, NCOLS], indexflag = INDEX_FLAG_DEFAULT, & - name = 'YR8', _RC) + r4_field = mk_field(r4_data, name = 'XR4', _RC) + r8_field = mk_field(r8_data, name = 'YR8', _RC) call FieldConvertPrec(r4_field, r8_field, _RC) call ESMF_FieldGet(r8_field, farrayPtr = r8_pointer, _RC) -! @assertEqual(r8_converted, r8_pointer) !wdb fixme temporarily disabled + @assertEqual(r8_converted, r8_pointer) end subroutine test_FieldConvertPrec_R4R8 - @Test - subroutine test_FieldClone3D() + @Test(npes=[4]) + subroutine test_FieldClone3D(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc @@ -380,8 +387,9 @@ contains end subroutine test_FieldClone3D - @Test - subroutine test_almost_equal_scalar() + @Test(npes=[4]) + subroutine test_almost_equal_scalar(this) + class(MpiTestMethod), intent(inout) :: this character(len=*), parameter :: MSG = 'Difference exceeds threshold' real(kind=ESMF_KIND_R8), parameter :: X = 1.0 / 3.0 real(kind=ESMF_KIND_R4) :: y @@ -391,8 +399,9 @@ contains end subroutine test_almost_equal_scalar - @Test - subroutine test_almost_equal_array() + @Test(npes=[4]) + subroutine test_almost_equal_array(this) + class(MpiTestMethod), intent(inout) :: this integer, parameter :: N = 3 character(len=*), parameter :: MSG = 'Difference exceeds threshold' real(kind=ESMF_KIND_R8), parameter :: DENOMS(N) = [3.0, 5.0, 7.0] @@ -406,47 +415,3 @@ contains end subroutine test_almost_equal_array end module Test_FieldBLAS -! @Test -! ! -! subroutine test_FieldGEMV_R4() -! real(kind=ESMF_KIND_R4), parameter :: alpha = 3.0 -! real(kind=ESMF_KIND_R4), parameter :: A(*,*,*) -! type(ESMF_Field) :: x -! real(kind=ESMF_KIND_R4), parameter :: beta = 2.0 -! type(ESMF_Field) :: y -! real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array -! real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr -! real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: y_array -! real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: y_ptr -! integer :: status, rc - -! allocate(x_array, source = R4_ARRAY_DEFAULT) -! allocate(y_array, source = R4_ARRAY_DEFAULT) -! y_array = y_array + 100 - -! do while(.TRUE.) -! x = mk_field(x_array, _RC) -! if(status /= ESMF_SUCCESS) exit - -! y = mk_field(y_array, _RC) -! if(status /= ESMF_SUCCESS) exit - -! call FieldAXPY(a, x, y, _RC) -! if(status /= ESMF_SUCCESS) exit -! -! call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) -! if(status /= ESMF_SUCCESS) exit - -! call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) -! if(status /= ESMF_SUCCESS) exit - -! @assertEqual(y_ptr, a*x_array+y_array) -! exit -! end do -! -! end subroutine test_FieldGEMV_R4 - -! @Test -! ! -! subroutine test_FieldSpread() -! end subroutine test_FieldSpread diff --git a/field_utils/tests/field_utils_setup.F90 b/field_utils/tests/field_utils_setup.F90 index 7ac898fd3d19..967753e98c3c 100644 --- a/field_utils/tests/field_utils_setup.F90 +++ b/field_utils/tests/field_utils_setup.F90 @@ -20,17 +20,17 @@ module field_utils_setup integer :: i type(ESMF_Index_Flag), parameter :: INDEX_FLAG_DEFAULT = ESMF_INDEX_DELOCAL - integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] - integer, parameter :: MAX_INDEX_DEFAULT(*) = [4, 4] - integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] - integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] - integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] - integer, parameter :: SIZE_R4 = 16 - integer, parameter :: SIZE_R8 = 16 +! integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] !wdb delete +! integer, parameter :: MAX_INDEX_DEFAULT(*) = [2, 2] !wdb delete +! integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] !wdb delete +! integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] !wdb delete +! integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] !wdb delete +! integer, parameter :: SIZE_R4 = 16 !wdb delete +! integer, parameter :: SIZE_R8 = 16 !wdb delete real, parameter :: undef = 42.0 - real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R4)], DIMR4_DEFAULT) - real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R8)], DIMR8_DEFAULT) + real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, 4)], [2,2]) + real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, 4)], [2,2]) type(ESMF_Field) :: XR4 type(ESMF_Field) :: XR8 @@ -44,11 +44,7 @@ module field_utils_setup contains ! MAKE GRID FOR FIELDS - function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result(grid) - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag + function mk_grid(grid_name, rc) result(grid) character(len=*), intent(in) :: grid_name integer, optional, intent(out) :: rc @@ -56,16 +52,12 @@ function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result integer :: status - grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, name = grid_name, _RC) + grid = ESMF_GridCreateNoPeriDim(countsPerDeDim1=[2,2], countsPerDeDim2=[2,2], indexflag=INDEX_FLAG_DEFAULT, name = grid_name, _RC) _RETURN(_SUCCESS) end function mk_grid - function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag + function mk_field_r4_ungrid(name, ungriddedLBound, ungriddedUBound, rc) result(field) character(len=*), intent(in) :: name integer, optional, intent(in) :: ungriddedLBound(:) integer, optional, intent(in) :: ungriddedUBound(:) @@ -75,17 +67,13 @@ function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungr integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R4, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) _RETURN(_SUCCESS) end function mk_field_r4_ungrid - function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r4_2d(farray, name, rc) result(field) real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(out) :: rc @@ -94,19 +82,16 @@ function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R4, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray + + ptr = farray _RETURN(_SUCCESS) end function mk_field_r4_2d - function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r8_2d(farray, name, rc) result(field) real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(out) :: rc @@ -115,19 +100,15 @@ function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R8, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray + ptr = farray _RETURN(_SUCCESS) end function mk_field_r8_2d - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) + function mk_field_common(tk, name, ungriddedLBound, ungriddedUBound, rc) result(field) type(ESMF_TypeKind_Flag), intent(in) :: tk - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(in) :: ungriddedLBound(:) integer, optional, intent(in) :: ungriddedUBound(:) @@ -138,8 +119,8 @@ function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ung type(ESMF_Field) :: field type(ESMF_Grid) :: grid integer :: status - - grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) + + grid = mk_grid(grid_name = name // GRID_SUFFIX, _RC) field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) _RETURN(_SUCCESS) @@ -183,4 +164,47 @@ subroutine initialize_array_R8(x, xmin, xrange) end subroutine initialize_array_R8 + function mk_r4field(r4array, field_name, rc) result(r4field) + type(ESMF_Field) :: r4field + real(kind=ESMF_KIND_R4), intent(in) :: r4array(:,:) + character(len=*), intent(in) :: field_name + integer, optional, intent(out) :: rc + + integer :: status + + r4field = mk_field(r4array, name = field_name, _RC) + + _RETURN(_SUCCESS) + + end function mk_r4field + + function mk_r8field(r8array, field_name, rc) result(r8field) + type(ESMF_Field) :: r8field + real(kind=ESMF_KIND_R8), intent(in) :: r8array(:,:) + character(len=*), intent(in) :: field_name + integer, optional, intent(out) :: rc + + integer :: status + + r8field = mk_field(r8array, name = field_name, _RC) + + _RETURN(_SUCCESS) + + end function mk_r8field + + function mk_r4ungrid_field(field_name, lbound, ubound, rc) result(r4field) + type(ESMF_Field) :: r4field + character(len=*), intent(in) :: field_name + integer, intent(in) :: lbound + integer, intent(in) :: ubound + integer, optional, intent(out) :: rc + + integer :: status + + r4field = mk_field_r4_ungrid(name = field_name, ungriddedLBound=[lbound],ungriddedUBound=[ubound],_RC) + + _RETURN(_SUCCESS) + + end function mk_r4ungrid_field + end module field_utils_setup diff --git a/generic/CMakeLists.txt b/generic/CMakeLists.txt index 901ec303d3ff..06b6468771dc 100644 --- a/generic/CMakeLists.txt +++ b/generic/CMakeLists.txt @@ -69,7 +69,7 @@ esma_add_library(${this} ) target_include_directories (${this} PUBLIC $) -target_link_libraries (${this} PUBLIC esmf NetCDF::NetCDF_Fortran) +target_link_libraries (${this} PUBLIC ESMF::ESMF NetCDF::NetCDF_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/generic/OpenMP_Support.F90 b/generic/OpenMP_Support.F90 index a6919efa4182..c2742a6c9a6c 100644 --- a/generic/OpenMP_Support.F90 +++ b/generic/OpenMP_Support.F90 @@ -595,6 +595,7 @@ subroutine copy_callbacks(state, multi_states, rc) type(CallbackMethodWrapper), pointer :: wrapper type(CallbackMap), pointer :: callbacks type(CallbackMapIterator) :: iter + procedure(), pointer :: userRoutine n_multi = size(multi_states) call get_callbacks(state, callbacks, _RC) @@ -604,7 +605,8 @@ subroutine copy_callbacks(state, multi_states, rc) do while (iter /= e) wrapper => iter%second() do i = 1, n_multi - call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=wrapper%userRoutine, _RC) + userRoutine => wrapper%userRoutine + call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=userRoutine, _RC) end do call iter%next() end do diff --git a/gridcomps/Cap/CMakeLists.txt b/gridcomps/Cap/CMakeLists.txt index c6136b4f63e3..20b70e3953fd 100644 --- a/gridcomps/Cap/CMakeLists.txt +++ b/gridcomps/Cap/CMakeLists.txt @@ -16,7 +16,7 @@ endif() esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.profiler MAPL.history MAPL.ExtData ${EXTDATA2G_TARGET} TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran $<$:FLAP::FLAP> $<$:FARGPARSE::fargparse>) diff --git a/gridcomps/Cap/FargparseCLI.F90 b/gridcomps/Cap/FargparseCLI.F90 index 48d6b5de335c..ea880708c87d 100644 --- a/gridcomps/Cap/FargparseCLI.F90 +++ b/gridcomps/Cap/FargparseCLI.F90 @@ -8,7 +8,7 @@ module MAPL_FargparseCLIMod use gFTL2_IntegerVector use mapl_KeywordEnforcerMod use mapl_ExceptionHandling - use mapl_CapOptionsMod, only: MAPL_CapOptions !Rename is for backward compatibility. Remove renaming for 3.0 + use mapl_CapOptionsMod, only: MAPL_CapOptions_ => MAPL_CapOptions !Rename is for backward compatibility. Remove renaming for 3.0 implicit none private @@ -45,7 +45,7 @@ subroutine I_extraoptions(parser, rc) function new_CapOptions_from_fargparse(unusable, dummy, extra, rc) result (cap_options) class(KeywordEnforcer), optional, intent(in) :: unusable - type (MAPL_CapOptions) :: cap_options + type (MAPL_CapOptions_) :: cap_options character(*), intent(in) :: dummy !Needed for backward compatibility. Remove after 3.0 procedure(I_extraoptions), optional :: extra integer, optional, intent(out) :: rc @@ -231,7 +231,7 @@ end subroutine add_command_line_options subroutine fill_cap_options(fargparseCLI, cap_options, unusable, rc) class(MAPL_FargparseCLI), intent(inout) :: fargparseCLI - type(MAPL_CapOptions), intent(out) :: cap_options + type(MAPL_CapOptions_), intent(out) :: cap_options class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: status @@ -417,7 +417,7 @@ end subroutine fill_cap_options !Function for backward compatibility. Remove for 3.0 function old_CapOptions_from_Fargparse( fargparseCLI, unusable, rc) result (cap_options) - type (MAPL_CapOptions) :: cap_options + type (MAPL_CapOptions_) :: cap_options type (MAPL_FargparseCLI), intent(inout) :: fargparseCLI class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index dbb2640df122..007d857d6da0 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -275,6 +275,8 @@ subroutine run_model(this, comm, unusable, rc) integer :: status class(Logger), pointer :: lgr logical :: file_exists + type (ESMF_VM) :: vm + character(len=:), allocatable :: esmfComm _UNUSED_DUMMY(unusable) @@ -293,11 +295,15 @@ subroutine run_model(this, comm, unusable, rc) ! If the file exists, we pass it into ESMF_Initialize, else, we ! use the one from the command line arguments if (file_exists) then - call ESMF_Initialize (configFileName='ESMF.rc', mpiCommunicator=comm, _RC) + call ESMF_Initialize (configFileName='ESMF.rc', mpiCommunicator=comm, vm=vm, _RC) else - call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, _RC) + call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, vm=vm, _RC) end if + ! We check to see if ESMF_COMM was built as mpiuni which is not allowed for MAPL + call ESMF_VmGet(vm, esmfComm = esmfComm, _RC) + _ASSERT( esmfComm /= 'mpiuni', 'ESMF_COMM=mpiuni is not allowed for MAPL') + ! Note per ESMF this is a temporary routine as eventually MOAB will ! be the only mesh generator. But until then, this allows us to ! test it @@ -435,21 +441,22 @@ subroutine initialize_mpi(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: ierror + integer :: ierror, status integer :: provided integer :: npes_world _UNUSED_DUMMY(unusable) - call MPI_Initialized(this%mpi_already_initialized, ierror) - _VERIFY(ierror) + !call MPI_Initialized(this%mpi_already_initialized, ierror) + !_VERIFY(ierror) + call ESMF_InitializePreMPI(_RC) if (.not. this%mpi_already_initialized) then -!!$ call MPI_Init_thread(MPI_THREAD_MULTIPLE, provided, ierror) -!!$ _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supporte by this MPI.') - call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierror) - _VERIFY(ierror) - _ASSERT(provided == MPI_THREAD_SINGLE, "MPI_THREAD_SINGLE not supported by this MPI.") + call MPI_Init_thread(MPI_THREAD_MULTIPLE, provided, ierror) + _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supported by this MPI.') +! call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierror) +! _VERIFY(ierror) +! _ASSERT(provided == MPI_THREAD_SINGLE, "MPI_THREAD_SINGLE not supported by this MPI.") end if call MPI_Comm_rank(this%comm_world, this%rank, ierror); _VERIFY(ierror) diff --git a/gridcomps/ExtData/CMakeLists.txt b/gridcomps/ExtData/CMakeLists.txt index f48868e1fe4f..51ccf7a3a3be 100644 --- a/gridcomps/ExtData/CMakeLists.txt +++ b/gridcomps/ExtData/CMakeLists.txt @@ -8,7 +8,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.pfio MAPL.griddedio MAPL_cfio_r4 TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 97d1e5d41c92..52f6507fe5ae 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -24,7 +24,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.base MAPL.generic MAPL.griddedio TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) target_include_directories (${this} PUBLIC $) diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 25ba48139cfe..269ae7317758 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -11,7 +11,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/gridcomps/History/MAPL_EpochSwathMod.F90 b/gridcomps/History/MAPL_EpochSwathMod.F90 index 62b94145df5f..ae42ac808963 100644 --- a/gridcomps/History/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/MAPL_EpochSwathMod.F90 @@ -29,27 +29,35 @@ module MAPL_EpochSwathMod use MAPL_DownbitMod use Plain_netCDF_Time use, intrinsic :: ISO_C_BINDING - use, intrinsic :: iso_fortran_env, only: REAL64 - use ieee_arithmetic, only: isnan => ieee_is_nan + use MAPL_CommsMod, only : MAPL_Am_I_Root implicit none - private - type, public :: samplerHQ + integer, parameter :: ngrid_max = 10 + + type, private :: K_V_CF + character(len=ESMF_MAXSTR) :: key + type(ESMF_config) :: cf + end type K_V_CF + + type, public :: samplerHQ type(ESMF_Clock) :: clock type(ESMF_Alarm) :: alarm type(ESMF_Time) :: RingTime type(ESMF_TimeInterval) :: Frequency_epoch - type(ESMF_config) :: config_grid_save - type(ESMF_grid) :: ogrid + integer :: ngrid = 0 character(len=ESMF_MAXSTR) :: grid_type + character(len=ESMF_MAXSTR) :: tunit + type (K_V_CF) :: CF_loc(ngrid_max) real*8 :: arr(2) contains procedure :: create_grid procedure :: regrid_accumulate => regrid_accumulate_on_xysubset procedure :: destroy_rh_regen_ogrid - procedure :: fill_time_in_bundle + procedure :: fill_time_in_bundle + procedure :: find_config + procedure :: config_accumulate end type samplerHQ interface samplerHQ @@ -67,7 +75,7 @@ module MAPL_EpochSwathMod logical :: doVertRegrid = .false. type(ESMF_FieldBundle) :: output_bundle type(ESMF_FieldBundle) :: input_bundle - type(ESMF_FieldBundle) :: acc_bundle + type(ESMF_FieldBundle) :: acc_bundle type(ESMF_Time) :: startTime integer :: regrid_method = REGRID_METHOD_BILINEAR integer :: nbits_to_keep = MAPL_NBITS_NOT_SET @@ -86,7 +94,7 @@ module MAPL_EpochSwathMod logical :: have_initalized contains !! procedure :: CreateFileMetaData - procedure :: Create_bundle_RH + procedure :: Create_bundle_RH procedure :: CreateVariable procedure :: regridScalar procedure :: regridVector @@ -95,7 +103,7 @@ module MAPL_EpochSwathMod procedure :: check_chunking procedure :: alphabatize_variables procedure :: addVariable_to_acc_bundle - procedure :: addVariable_to_output_bundle + procedure :: addVariable_to_output_bundle procedure :: interp_accumulate_fields end type sampler @@ -105,36 +113,36 @@ module MAPL_EpochSwathMod contains - function new_samplerHQ(clock, config, key, rc) result(hq) + ! + ! in MAPL_HistoryGridComp.F90, Hsampler get its config and key + ! from the first SwathGrid entry in HISTORY.rc + ! thus + ! there is only one frequency_epoch for all the SwathGrid usage + ! + function new_samplerHQ(clock, key, config, rc) result(hq) implicit none type(samplerHQ) :: hq - type(ESMF_Clock), intent(in) :: clock + type(ESMF_Clock), intent(in) :: clock + character(len=*), intent(in) :: key type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: key - integer, optional, intent(out) :: rc + integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR) :: time_string integer :: status + integer :: second integer :: time_integer - type(ESMF_Time) :: RingTime_epoch - type(ESMF_Time) :: startTime - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: timeStep + type(ESMF_Time) :: startTime + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep type(ESMF_TimeInterval) :: Frequency_epoch - integer :: sec, second - integer :: n1 - type(ESMF_Config) :: cf - hq%clock= clock - hq%config_grid_save= config - hq%arr(1:2) = -2.d0 call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) call ESMF_ClockGet ( clock, timestep=timestep, _RC ) call ESMF_ClockGet ( clock, startTime=startTime, _RC ) call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(key)//'.Epoch:', default=0, _RC) + call ESMF_ConfigGetAttribute(config, value=hq%tunit, label=trim(key)//'.tunit:', default="", _RC) _ASSERT(time_integer /= 0, 'Epoch value in config wrong') second = hms_2_s (time_integer) call ESMF_TimeIntervalSet(frequency_epoch, s=second, _RC) @@ -146,7 +154,44 @@ function new_samplerHQ(clock, config, key, rc) result(hq) _RETURN(_SUCCESS) end function new_samplerHQ - + + + function find_config (this, key, rc) result(cf) + class(samplerHQ) :: this + character(len=*) , intent(in) :: key + type(ESMF_Config) :: cf + integer, intent(out), optional :: rc + integer :: status + integer :: i, j + + j=0 + do i=1, this%ngrid + if ( trim(key) == trim(this%CF_loc(i)%key) ) then + cf = this%CF_loc(i)%cf + j=j+1 + exit + end if + end do + + _ASSERT( j>0 , trim(key)//' is not found in Hsampler CF_loc(:)') + + _RETURN(_SUCCESS) + end function find_config + + + subroutine config_accumulate (this, key, cf, rc) + class(samplerHQ) :: this + type(ESMF_Config), intent(in) :: cf + character(len=*) , intent(in) :: key + integer, intent(out), optional :: rc + integer :: status + + this%ngrid = this%ngrid + 1 + this%CF_loc(this%ngrid)%key = trim(key) + this%CF_loc(this%ngrid)%cf = cf + _RETURN(_SUCCESS) + end subroutine config_accumulate + !--------------------------------------------------! ! __ set @@ -161,24 +206,26 @@ function create_grid(this, key, currTime, grid_type, rc) result(ogrid) character(len=*), optional, intent(in) :: grid_type integer, intent(out), optional :: rc integer :: status - + type(ESMF_Config) :: config_grid character(len=ESMF_MAXSTR) :: time_string - logical :: ispresent if (present(grid_type)) this%grid_type = trim(grid_type) - config_grid = this%config_grid_save + config_grid = this%find_config(key) call ESMF_TimeGet(currTime, timeString=time_string, _RC) - ! + + ! ! -- the `ESMF_ConfigSetAttribute` shows a risk ! to overwrite the nextline in config ! call ESMF_ConfigSetAttribute( config_grid, trim(time_string), label=trim(key)//'.Epoch_init:', _RC) + ogrid = grid_manager%make_grid(config_grid, prefix=trim(key)//'.', _RC ) - this%ogrid = ogrid + !! call grid_validate (ogrid,) + _RETURN(_SUCCESS) - + end function create_grid @@ -187,38 +234,31 @@ subroutine regrid_accumulate_on_xysubset (this, sp, rc) class(sampler), intent(inout) :: sp integer, intent(out), optional :: rc integer :: status - - class(AbstractGridFactory), pointer :: factory - integer :: xy_subset(2,2) - type(ESMF_Time) :: timeset(2) - type(ESMF_Time) :: current_time - type(ESMF_TimeInterval) :: dur - character(len=ESMF_MAXSTR) :: time_string - integer, allocatable :: global_xy_mask(:,:) - integer, allocatable :: local_xy_mask(:,:) + class(AbstractGridFactory), pointer :: factory + type(ESMF_Time) :: timeset(2) + type(ESMF_Time) :: current_time + type(ESMF_TimeInterval) :: dur + integer :: xy_subset(2,2) - integer :: counts(5) - integer :: dims(3) - integer :: m1, m2 - ! __ s1. get xy_subset - factory => grid_manager%get_factory(this%ogrid,_RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) timeset(1) = current_time - dur timeset(2) = current_time + + factory => grid_manager%get_factory(sp%output_grid,_RC) call factory%get_xy_subset( timeset, xy_subset, _RC) - + ! __ s2. interpolate then save data using xy_mask call sp%interp_accumulate_fields (xy_subset, _RC) _RETURN(ESMF_SUCCESS) - - end subroutine regrid_accumulate_on_xysubset - + + end subroutine regrid_accumulate_on_xysubset + subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) implicit none @@ -226,37 +266,30 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) class(sampler) :: sp type (StringGridMap), target, intent(inout) :: output_grids character(len=*), intent(in) :: key_grid_label - integer, intent(out), optional :: rc + integer, intent(out), optional :: rc integer :: status - - class(AbstractGridFactory), pointer :: factory + type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: dur - character(len=ESMF_MAXSTR) :: time_string - type(ESMF_Grid), pointer :: pgrid type(ESMF_Grid) :: ogrid - type(ESMF_Grid) :: input_grid character(len=ESMF_MAXSTR) :: key_str type (StringGridMapIterator) :: iter character(len=:), pointer :: key - type (ESMF_Config) :: config_grid - + integer :: i, numVars character(len=ESMF_MAXSTR), allocatable :: names(:) type(ESMF_Field) :: field - + if ( .NOT. ESMF_AlarmIsRinging(this%alarm) ) then - write(6,*) 'ck: regen, not in alarming' - rc=0 - return + _RETURN(ESMF_SUCCESS) endif - !__ s1. destroy ogrid + regen ogrid + !__ s1. destroy ogrid + RH, regen ogrid + + key_str = trim(key_grid_label) + pgrid => output_grids%at(key_str) - key_str=trim(key_grid_label) - pgrid => output_grids%at(trim(key_grid_label)) call grid_manager%destroy(pgrid,_RC) call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC ) @@ -266,19 +299,18 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) if (trim(key)==trim(key_str)) then ogrid = this%create_grid (key_str, currTime, _RC) call output_grids%set(key, ogrid) - this%ogrid = ogrid endif call iter%next() enddo !__ s2. destroy RH - call sp%regrid_handle%destroy(_RC) - + + !__ s3. destroy acc_bundle / output_bundle - + call ESMF_FieldBundleGet(sp%acc_bundle,fieldCount=numVars,_RC) allocate(names(numVars),stat=status) call ESMF_FieldBundleGet(sp%acc_bundle,fieldNameList=names,_RC) @@ -298,18 +330,19 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) _RETURN(ESMF_SUCCESS) - + end subroutine destroy_rh_regen_ogrid - subroutine fill_time_in_bundle (this, xname, bundle, rc) + subroutine fill_time_in_bundle (this, xname, bundle, ogrid, rc) implicit none class(samplerHQ) :: this character(len=*), intent(in) :: xname type(ESMF_FieldBundle), intent(inout) :: bundle integer, optional, intent(out) :: rc - integer :: status + integer :: status + type(ESMF_Grid), intent(in) :: ogrid class(AbstractGridFactory), pointer :: factory type(ESMF_Field) :: field real(kind=ESMF_KIND_R4), pointer :: ptr2d(:,:) @@ -317,16 +350,16 @@ subroutine fill_time_in_bundle (this, xname, bundle, rc) ! __ get field xname='time' call ESMF_FieldBundleGet (bundle, xname, field=field, _RC) call ESMF_FieldGet (field, farrayptr=ptr2d, _RC) - + ! __ obs_time from swath factory - factory => grid_manager%get_factory(this%ogrid,_RC) - call factory%get_obs_time (this%ogrid, ptr2d, _RC) - + factory => grid_manager%get_factory(ogrid,_RC) + call factory%get_obs_time (ogrid, ptr2d, _RC) + _RETURN(ESMF_SUCCESS) end subroutine fill_time_in_bundle - + function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,read_collection_id, & metadata_collection_id,regrid_method,fraction,items,rc) result(GriddedIO) type(sampler) :: GriddedIO @@ -354,14 +387,14 @@ function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,rea end function new_sampler - subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attributes,rc) + subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) class (sampler), intent(inout) :: this type(GriddedIOitemVector), target, intent(inout) :: items type(ESMF_FieldBundle), intent(inout) :: bundle + character(len=*), intent(in) :: tunit type(TimeData), optional, intent(inout) :: timeInfo type(VerticalData), intent(inout), optional :: vdata type (ESMF_Grid), intent(inout), pointer, optional :: ogrid - type(StringStringMap), target, intent(in), optional :: global_attributes integer, intent(out), optional :: rc type(ESMF_Grid) :: input_grid @@ -370,10 +403,6 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib type(ESMF_Field) :: new_field type(GriddedIOitemVectorIterator) :: iter type(GriddedIOitem), pointer :: item - type(stringVector) :: order - integer :: metadataVarsSize - type(StringStringMapIterator) :: s_iter - character(len=:), pointer :: attr_name, attr_val integer :: status this%items = items @@ -418,7 +447,7 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib this%vdata=VerticalData(rc=status) _VERIFY(status) end if - + call this%vdata%append_vertical_metadata(this%metadata,this%input_bundle,rc=status) _VERIFY(status) this%doVertRegrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) @@ -450,7 +479,7 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib item => iter%get() call this%addVariable_to_acc_bundle(item%xname,_RC) if (item%itemType == ItemTypeVector) then - call this%addVariable_to_acc_bundle(item%yname,_RC) + call this%addVariable_to_acc_bundle(item%yname,_RC) end if call iter%next() enddo @@ -460,13 +489,16 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib ! new_field = ESMF_FieldCreate(this%output_grid ,name='time', & typekind=ESMF_TYPEKIND_R4,_RC) + ! + ! add attribute + ! + call ESMF_AttributeSet(new_field,'UNITS',trim(tunit),_RC) call MAPL_FieldBundleAdd( this%acc_bundle, new_field, _RC ) - _RETURN(_SUCCESS) end subroutine Create_Bundle_RH - + subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,rc) class (sampler), intent(inout) :: this integer, optional, intent(in) :: deflation @@ -577,9 +609,7 @@ subroutine CreateVariable(this,itemName,rc) integer :: fieldRank logical :: isPresent character(len=ESMF_MAXSTR) :: varName,longName,units - character(len=:), allocatable :: grid_dims - character(len=:), allocatable :: vdims - type(Variable) :: v + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) _VERIFY(status) @@ -641,7 +671,7 @@ subroutine RegridScalar(this,itemName,rc) type(ESMF_Grid) :: gridIn,gridOut logical :: hasDE_in, hasDE_out logical :: first_entry - + call ESMF_FieldBundleGet(this%output_bundle,itemName,field=outField,rc=status) _VERIFY(status) call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) @@ -714,8 +744,8 @@ subroutine RegridScalar(this,itemName,rc) !! print *, maxval(ptr2d) !! print *, minval(ptr2d) !! print *, maxval(outptr2d) -!! print *, minval(outptr2d) - +!! print *, minval(outptr2d) + else if (fieldRank==3) then if (.not.associated(ptr3d)) then if (hasDE_in) then @@ -914,7 +944,7 @@ subroutine RegridVector(this,xName,yName,rc) end subroutine RegridVector - + subroutine alphabatize_variables(this,nfixedVars,rc) class (sampler), intent(inout) :: this integer, intent(in) :: nFixedVars @@ -967,18 +997,14 @@ subroutine alphabatize_variables(this,nfixedVars,rc) end subroutine alphabatize_variables - + subroutine addVariable_to_acc_bundle(this,itemName,rc) class (sampler), intent(inout) :: this character(len=*), intent(in) :: itemName integer, optional, intent(out) :: rc type(ESMF_Field) :: field,newField - type(ESMF_Array) :: array1 - real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:) - class (AbstractGridFactory), pointer :: factory integer :: fieldRank - logical :: isPresent integer :: status call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) @@ -1001,9 +1027,7 @@ subroutine addVariable_to_output_bundle(this,itemName,rc) integer, optional, intent(out) :: rc type(ESMF_Field) :: field,newField - class (AbstractGridFactory), pointer :: factory integer :: fieldRank - logical :: isPresent integer :: status call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) @@ -1017,8 +1041,8 @@ subroutine addVariable_to_output_bundle(this,itemName,rc) _RETURN(_SUCCESS) end subroutine addVariable_to_output_bundle - - + + !! -- based on subroutine bundlepost(this,filename,oClients,rc) !! @@ -1033,23 +1057,20 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) type(ESMF_Field) :: outField type(ESMF_Field) :: new_outField type(ESMF_Grid) :: grid - integer :: tindex - type(ArrayReference) :: ref type(GriddedIOitemVectorIterator) :: iter type(GriddedIOitem), pointer :: item - logical :: have_time type(ESMF_Array) :: array1, array2 integer :: is,ie,js,je - integer :: rank, rank1, rank2 + integer :: rank real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:), pt2d_(:,:) real(KIND=ESMF_KIND_R4), pointer :: pt3d(:,:,:), pt3d_(:,:,:) integer :: localDe, localDECount integer, dimension(:), allocatable :: LB, UB, exclusiveCount - integer, dimension(:), allocatable :: compLB, compUB, compCount + integer, dimension(:), allocatable :: compLB, compUB, compCount integer :: dimCount integer :: y1, y2 integer :: j, jj @@ -1059,16 +1080,21 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) is=xy_subset(1,1); ie=xy_subset(2,1) js=xy_subset(1,2); je=xy_subset(2,2) + if (js > je) then + ! no valid points are found on swath grid for this time step + _RETURN(ESMF_SUCCESS) + end if + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then call this%vdata%setup_eta_to_pressure(regrid_handle=this%regrid_handle,output_grid=this%output_grid,rc=status) _VERIFY(status) end if - + call ESMF_FieldBundleGet(this%output_bundle, grid=grid, _RC) call ESMF_GridGet(grid, localDECount=localDECount, dimCount=dimCount, _RC) allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ) - allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) - + allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) + allocate ( j1(0:localDEcount-1) ) ! start allocate ( j2(0:localDEcount-1) ) ! end @@ -1079,7 +1105,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) LB(1)=ii1; LB(2)=jj1 UB(1)=iin; UB(2)=jjn - + do localDe=0, localDEcount-1 ! ! is/ie, js/je, [LB, UB] @@ -1114,7 +1140,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) !! write(6,*) 'j1(localDe)', j1(0:localDeCount-1) !! write(6,*) 'j2(localDe)', j2(0:localDeCount-1) - + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1170,7 +1196,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) end subroutine interp_accumulate_fields - + subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) implicit none type(ESMF_Grid), intent(in) :: grid @@ -1180,12 +1206,10 @@ subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) integer :: status integer :: ii1, iin, jj1, jjn ! local box for localDE - integer :: is, ie, js, je ! global box for each time-interval - integer :: j1p, jnp ! local y-index for each time-interval + integer :: is,ie, js, je ! global box for each time-interval - integer :: dimCount integer :: y1, y2 - integer :: j, jj + integer :: jj integer :: j1, j2 is=xy_subset(1,1); ie=xy_subset(2,1) @@ -1230,5 +1254,5 @@ subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) end subroutine get_xy_mask - + end module MAPL_EpochSwathMod diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index a29439905bbd..9f5329b99ec5 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -405,6 +405,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! variables for counting table integer :: nline, ncol + integer :: swath_count type(HistoryCollection) :: collection character(len=ESMF_MAXSTR) :: cFileOrder @@ -601,6 +602,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo + swath_count = 0 iter = IntState%output_grids%begin() do while (iter /= IntState%output_grids%end()) key => iter%key() @@ -620,7 +622,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (trim(grid_type)/='Swath') then output_grid = grid_manager%make_grid(config, prefix=key//'.', _RC) else - Hsampler = samplerHQ(clock, config, key, _RC) + swath_count = swath_count + 1 + ! + ! Hsampler use the first config to setup epoch + ! + if (swath_count == 1) then + Hsampler = samplerHQ(clock, key, config, _RC) + end if + call Hsampler%config_accumulate(key, config, _RC) output_grid = Hsampler%create_grid(key, currTime, grid_type=grid_type, _RC) end if call IntState%output_grids%set(key, output_grid) @@ -628,6 +637,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end do end block OUTPUT_GRIDS end if + if (intstate%version >= 2) then call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', _RC) table_end = .false. @@ -641,7 +651,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if call ESMF_ConfigNextLine ( config,tableEnd=table_end,_RC ) enddo - + field_set_iter = intState%field_sets%begin() do while (field_set_iter /= intState%field_sets%end()) key => field_set_iter%key() @@ -706,7 +716,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( MAPL_AM_I_ROOT(vm) ) then call regen_rcx_for_obs_platform (config, nlist, list, _RC) end if - + call ESMF_VMbarrier(vm, _RC) ! Initialize History Lists @@ -897,6 +907,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) endif endif + ! Handle "backwards" mode: this is hidden (i.e. not documented) feature ! Defaults to .false. call ESMF_ConfigGetAttribute ( cfg, reverse, default=0, & @@ -1635,6 +1646,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else sec = MAPL_nsecf(list(n)%frequency) / 2 endif + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then + call ESMF_TimeIntervalGet(Hsampler%Frequency_epoch, s=sec, _RC) + end if call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, _RC ) end do @@ -2371,7 +2385,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else list(n)%vdata = VerticalData(positive=list(n)%positive,_RC) end if - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call list(n)%xsampler%set_param(deflation=list(n)%deflate,_RC) call list(n)%xsampler%set_param(quantize_algorithm=list(n)%quantize_algorithm,_RC) call list(n)%xsampler%set_param(quantize_level=list(n)%quantize_level,_RC) @@ -2400,14 +2414,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%timeseries_output) then list(n)%trajectory = HistoryTrajectory(cfg,string,clock,_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 == '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) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) - call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) + call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,Hsampler%tunit,ogrid=pgrid,vdata=list(n)%vdata,_RC) else if (trim(list(n)%output_grid_label)/='') then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) @@ -3371,7 +3386,7 @@ subroutine Run ( gc, import, export, clock, rc ) Writing(n) = .false. else if (list(n)%timeseries_output) then Writing(n) = ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) - else if (trim(list(n)%output_grid_label)=='SwathGrid') then + else if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then Writing(n) = ESMF_AlarmIsRinging ( Hsampler%alarm ) else Writing(n) = ESMF_AlarmIsRinging ( list(n)%his_alarm ) @@ -3419,13 +3434,12 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_grid_case: do n=1,nlist - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call Hsampler%regrid_accumulate(list(n)%xsampler,_RC) if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then create_mode = PFIO_NOCLOBBER ! defaut no overwrite if (intState%allow_overwrite) create_mode = PFIO_CLOBBER - ! add time to items ! true metadata comes here from mGriddedIO%metadata ! the mGriddedIO below only touches metadata, collection_id etc., it is safe. @@ -3437,7 +3451,7 @@ subroutine Run ( gc, import, export, clock, rc ) item%itemType = ItemTypeScalar item%xname = 'time' call list(n)%items%push_back(item) - call Hsampler%fill_time_in_bundle ('time', list(n)%xsampler%acc_bundle, _RC) + call Hsampler%fill_time_in_bundle ('time', list(n)%xsampler%acc_bundle, list(n)%xsampler%output_grid, _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() @@ -3526,7 +3540,7 @@ subroutine Run ( gc, import, export, clock, rc ) inquire (file=trim(filename(n)),exist=file_exists) _ASSERT(.not.file_exists,trim(filename(n))//" being created for History output already exists") end if - if (trim(list(n)%output_grid_label)/='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') == 0) then call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,_RC) endif list(n)%currentFile = filename(n) @@ -3655,13 +3669,15 @@ subroutine Run ( gc, import, export, clock, rc ) ! destroy ogrid/RH/acc_bundle, regenerate them ! swath only epoch_swath_regen_grid: do n=1,nlist - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then + 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,ogrid=pgrid,& - vdata=list(n)%vdata,global_attributes=global_attributes,_RC) + 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,'(//)') endif end if @@ -5240,10 +5256,11 @@ function get_acc_offset(current_time,ref_time,rc) result(acc_offset) end if _RETURN(_SUCCESS) end function - - + + ! __ read data to object: obs_platform ! __ for each collection: find union fields, write to collection.rcx + ! __ note: this subroutine is called by MPI root only ! subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) use MAPL_scan_pattern_in_file @@ -5251,7 +5268,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) ! ! Plan: !- read and write schema - !- extract union of field lines, print out to rc + !- extract union of field lines, print out to rc + integer, parameter :: ESMF_MAXSTR2 = 2*ESMF_MAXSTR type(ESMF_Config), intent(inout) :: config integer, intent(in) :: nlist type(HistoryCollection), pointer :: list(:) @@ -5259,21 +5277,21 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) character(len=ESMF_MAXSTR) :: HIST_CF integer :: n, unitr, unitw - logical :: match, contLine, con3 + logical :: match, contLine, con integer :: status - character (len=ESMF_MAXSTR) :: fname character (len=ESMF_MAXSTR) :: marker - character (len=ESMF_MAXSTR) :: line, line2 character (len=ESMF_MAXSTR) :: string - character (len=ESMF_MAXSTR), allocatable :: str_piece(:) + character (len=ESMF_MAXSTR2) :: line, line2 + character (len=ESMF_MAXSTR2), allocatable :: str_piece(:) type(obs_platform), allocatable :: PLFS(:) type(obs_platform) :: p1 - integer :: k, i, j + integer :: k, i, j, m, i2 integer :: ios, ngeoval, count, nplf integer :: length_mx integer :: mxseg integer :: nseg + integer :: nseg_ub integer :: nfield, nplatform integer :: nentry_name logical :: obs_flag @@ -5283,12 +5301,11 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) lgr => logging%get_logger('HISTORY.sampler') ! - ! -- note: work on HEAD node ! call ESMF_ConfigGetAttribute(config, value=HIST_CF, & label="HIST_CF:", default="HIST.rc", _RC ) unitr = GETFILE(HIST_CF, FORM='formatted', _RC) - + call scan_count_match_bgn (unitr, 'PLATFORM.', count, .false.) rewind(unitr) call lgr%debug('%a %i8','count PLATFORM.', count) @@ -5299,8 +5316,12 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) nplf = count allocate (PLFS(nplf)) allocate (map(nplf)) - - ! __ s1. scan get platform name + nc_index/lat/lon/time + + ! __ global set for call split_string by space + length_mx = ESMF_MAXSTR2 + mxseg = 100 + + ! __ s1. scan get platform name + index_name_x var_name_lat/lon/time do k=1, count call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) @@ -5313,53 +5334,51 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) call lgr%debug('%a %a', 'marker=', trim(marker)) call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'index:', .false.) + call scan_contain(unitr, 'index_name_x:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_index = trim(line(i+1:)) + PLFS(k)%index_name_x = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'longitude:', .false.) + call scan_contain(unitr, 'var_name_lon:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_lon = trim(line(i+1:)) - - call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'latitude:', .false.) + PLFS(k)%var_name_lon = trim(line(i+1:)) + + call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, 'var_name_lat:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_lat = trim(line(i+1:)) + PLFS(k)%var_name_lat = trim(line(i+1:)) - call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'time:', .false.) + call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, 'var_name_time:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_time = trim(line(i+1:)) + PLFS(k)%var_name_time = trim(line(i+1:)) - call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'file_name_template:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%file_name_template = trim(line(i+1:)) + PLFS(k)%file_name_template = trim(line(i+1:)) call lgr%debug('%a %a %a %a %a', & trim( PLFS(k)%name ), & - trim( PLFS(k)%nc_lon ), & - trim( PLFS(k)%nc_lat ), & - trim( PLFS(k)%nc_time ), & + trim( PLFS(k)%var_name_lon ), & + trim( PLFS(k)%var_name_lat ), & + trim( PLFS(k)%var_name_time ), & trim( PLFS(k)%file_name_template ) ) end do ! __ s2.1 scan fields: get ngeoval / nentry_name = nword - length_mx = ESMF_MAXSTR - mxseg = 10 allocate (str_piece(mxseg)) rewind(unitr) do k=1, count @@ -5369,27 +5388,29 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) i=index(line, 'PLATFORM.') j=index(line, ':') marker=line(1:j) - call scan_begin(unitr, marker, .true.) + call scan_begin(unitr, marker, .true.) call scan_contain(unitr, 'geovals_fields:', .false.) ios=0 ngeoval=0 + nseg_ub=0 do while (ios == 0) read (unitr, '(A)' ) line - i=index(line, '::') - if (i==0) then + con = .not.(adjustl(trim(line))=='::') + if (con) then ngeoval = ngeoval + 1 call split_string_by_space (line, length_mx, mxseg, & nseg, str_piece, status) + nseg_ub = max(nseg_ub, nseg) else exit endif enddo PLFS(k)%ngeoval = ngeoval - PLFS(k)%nentry_name = nseg + PLFS(k)%nentry_name = nseg_ub !! call lgr%debug('%a %i','ngeoval=', ngeoval) - - allocate ( PLFS(k)%field_name (nseg, ngeoval) ) - nentry_name = nseg ! assume the same for each field_name + allocate ( PLFS(k)%field_name (nseg_ub, ngeoval) ) + PLFS(k)%field_name = '' +!! nentry_name = nseg_ub ! assume the same for each field_name end do @@ -5403,18 +5424,21 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) j=index(line, ':') marker=line(1:j) ! - call scan_begin(unitr, marker, .true.) + call scan_begin(unitr, marker, .true.) call scan_contain(unitr, 'geovals_fields:', .false.) ios=0 ngeoval=0 do while (ios == 0) - read (unitr, '(A)' ) line - i=index(line, '::') - if (i==0) then + read (unitr, '(A)', iostat = ios) line + !! write(6,*) 'k in count, line', k, trim(line) + con = .not.(adjustl(trim(line))=='::') + if (con) then ngeoval = ngeoval + 1 call split_string_by_space (line, length_mx, mxseg, & nseg, str_piece, status) - PLFS(k)%field_name (1:nseg, ngeoval) = str_piece(1:nseg) + do m=1, nseg + PLFS(k)%field_name (m, ngeoval) = trim(str_piece(m)) + end do else exit endif @@ -5422,10 +5446,10 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) end do deallocate(str_piece) rewind(unitr) - + !!do k=1, nplf !! do i=1, ngeoval - !! write(6,*) 'PLFS(k)%field_name (1:nseg, ngeoval)=', PLFS(k)%field_name (1:nseg,i) + !! write(6,*) 'PLFS(k)%field_name (1:nseg, ngeoval)=', PLFS(k)%field_name (1:nseg,1) !! enddo !!enddo !!write(6,*) 'nlist=', nlist @@ -5455,52 +5479,56 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) if (contLine) then if (adjustl(line) == '::') contLine = .false. end if - if ( index(line, trim(string)//'ObsPlatforms:') > 0 ) then + if ( index(adjustl(line), trim(string)//'ObsPlatforms:') == 1 ) then obs_flag =.true. line2 = line + write(6,*) 'first line for ObsPlatforms:=', trim(line) + endif end do 1236 continue if (obs_flag) then - ! __ write common nc_index,time,lon,lat - k=1 ! plat form # 1 - write(unitw, '(2(2x,a))') trim(string)//'nc_Index: ', trim(adjustl(PLFS(k)%nc_index)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Time: ', trim(adjustl(PLFS(k)%nc_time)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Longitude:', trim(adjustl(PLFS(k)%nc_lon)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Latitude: ', trim(adjustl(PLFS(k)%nc_lat)) - write(unitw, '(/)') - - length_mx = ESMF_MAXSTR - mxseg = 100 allocate (str_piece(mxseg)) i = index(line2, ':') line = adjustl ( line2(i+1:) ) + write(6,*) 'line for obsplatforms=', trim(line) call split_string_by_space (line, length_mx, mxseg, & - nplatform, str_piece, status) -! write(6,*) 'nplatform=', nplatform -! write(6,*) 'str_piece=', str_piece(1:nplatform) -! do j=1, nplf -! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) -! enddo + nplatform, str_piece, status) + + + write(6,*) 'split string, nplatform=', nplatform + write(6,*) 'nplf=', nplf + !!write(6,*) 'str_piece=', str_piece(1:nplatform) + !!do j=1, nplf + !! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) + !!enddo + ! ! a) union the platform ! - ! ! find the index for each str_piece map(:) = -1 - do i=1, nplatform ! loc collection + do i=1, nplatform ! for loc collection do j=1, nplf ! tot if ( trim(str_piece(i)) == trim( PLFS(j)%name ) ) then map(i)=j + exit end if end do end do deallocate(str_piece) + !! write(6,*) 'collection n=',n, 'map(:)=', map(:) + + ! __ write common nc_index,time,lon,lat + k=map(1) ! plat form # 1 + write(unitw, '(2(2x,a))') trim(string)//'index_name_x: ', trim(adjustl(PLFS(k)%index_name_x)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_time: ', trim(adjustl(PLFS(k)%var_name_time)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_lon: ', trim(adjustl(PLFS(k)%var_name_lon)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_lat: ', trim(adjustl(PLFS(k)%var_name_lat)) - !!write(6,*) 'map(:)=', map(:) do i=1, nplatform k=map(i) if (i==1) then @@ -5520,13 +5548,16 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) if (j==1) then write(unitw, '(10(2x,a))') trim(string)//'fields:', trim(line) else - write(unitw, '(12x,a)') trim(line) + write(unitw, '(12x,a)') trim(line) end if end do write(unitw,'(a,/)') '::' - write(unitw,'(a)') 'geovals.obs_files: # table start from next line' + write(unitw,'(a)') trim(string)//'obs_files: # table start from next line' + - do k=1, nplatform + write(6,*) 'nplatform', nplatform + do i2=1, nplatform + k=map(i2) write(unitw, '(a)') trim(adjustl(PLFS(k)%file_name_template)) do j=1, PLFS(k)%ngeoval line='' @@ -5543,7 +5574,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) end do call free_file(unitr, _RC) + _RETURN(ESMF_SUCCESS) end subroutine regen_rcx_for_obs_platform - + end module MAPL_HistoryGridCompMod diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 34aa412ef6c1..9efd6ca1ac25 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -40,16 +40,21 @@ module HistoryTrajectoryMod type(ESMF_Clock) :: clock type(ESMF_Alarm), public :: alarm type(ESMF_Time) :: RingTime - type(ESMF_TimeInterval) :: epoch_frequency + type(ESMF_TimeInterval), public :: epoch_frequency integer :: nobs_type - character(len=ESMF_MAXSTR) :: nc_index - character(len=ESMF_MAXSTR) :: nc_time - character(len=ESMF_MAXSTR) :: nc_latitude - character(len=ESMF_MAXSTR) :: nc_longitude +! character(len=ESMF_MAXSTR) :: nc_index +! character(len=ESMF_MAXSTR) :: nc_time +! character(len=ESMF_MAXSTR) :: nc_latitude +! character(len=ESMF_MAXSTR) :: nc_longitude + + character(len=ESMF_MAXSTR) :: index_name_x character(len=ESMF_MAXSTR) :: var_name_time character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_time_full + character(len=ESMF_MAXSTR) :: var_name_lat_full + character(len=ESMF_MAXSTR) :: var_name_lon_full character(len=ESMF_MAXSTR) :: datetime_units integer :: epoch ! unit: second integer(kind=ESMF_KIND_I8) :: epoch_index(2) @@ -61,9 +66,9 @@ module HistoryTrajectoryMod type(ESMF_TimeInterval) :: obsfile_interval integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index - logical :: is_valid + logical :: active contains - procedure :: initialize + procedure :: initialize => initialize_ procedure :: create_variable => create_metadata_variable procedure :: create_file_handle procedure :: close_file_handle @@ -89,7 +94,7 @@ module function HistoryTrajectory_from_config(config,string,clock,rc) result(tra integer, optional, intent(out) :: rc end function HistoryTrajectory_from_config - module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) + module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) class(HistoryTrajectory), intent(inout) :: this type(GriddedIOitemVector), optional, intent(inout) :: items type(ESMF_FieldBundle), optional, intent(inout) :: bundle @@ -97,7 +102,7 @@ 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_metadata_variable(this,vname,rc) class(HistoryTrajectory), intent(inout) :: this diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 1f13c1b6a3d0..d266b34e1f93 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -38,8 +38,8 @@ character(len=ESMF_MAXSTR) :: symd, shms integer :: nline, col integer, allocatable :: ncol(:) - character(len=ESMF_MAXSTR), allocatable :: word(:) - integer :: nobs, head, jvar + character(len=ESMF_MAXSTR), allocatable :: word(:) + integer :: nobs, head, jvar logical :: tend integer :: i, j, k, M integer :: count @@ -58,15 +58,14 @@ traj%alarm = ESMF_AlarmCreate( clock=clock, RingInterval=epoch_frequency, & RingTime=traj%RingTime, sticky=.false., _RC ) - call ESMF_ConfigGetAttribute(config, value=traj%nc_index, default="", & - label=trim(string) // 'nc_Index:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_time, default="", & - label=trim(string) // 'nc_Time:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_longitude, default="", & - label=trim(string) // 'nc_Longitude:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_latitude, default="", & - label=trim(string) // 'nc_Latitude:', _RC) - + call ESMF_ConfigGetAttribute(config, value=traj%index_name_x, default="", & + label=trim(string) // 'index_name_x:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lon_full, default="", & + label=trim(string) // 'var_name_lon:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lat_full, default="", & + label=trim(string) // 'var_name_lat:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_time_full, default="", & + label=trim(string) // 'var_name_time:', _RC) call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label=trim(string) // 'obs_file_begin:', _RC) @@ -114,7 +113,7 @@ shms=trim(STR1) endif call convert_twostring_2_esmfinterval (symd, shms, traj%obsfile_interval, _RC) - traj%is_valid = .true. + traj%active = .true. ! __ s1. overall print @@ -130,7 +129,8 @@ !!write(6,*) 'line', i, 'ncol(i)', ncol(i) enddo - + + ! __ s2. find nobs && distinguish design with vs wo '------' nobs=0 call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) @@ -141,11 +141,12 @@ enddo ! __ s3. retrieve template and geoval, set metadata file_handle - lgr => logging%get_logger('HISTORY.sampler') + lgr => logging%get_logger('HISTORY.sampler') if ( nobs == 0 ) then ! ! treatment-1: ! + _FAIL('this setting in HISTORY.rc obs_files: is not supported, stop') traj%nobs_type = nline ! here .rc format cannot have empty spaces allocate (traj%obs(nline)) call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) @@ -160,13 +161,12 @@ ! treatment-2: ! traj%nobs_type = nobs - allocate (traj%obs(nobs)) + allocate (traj%obs(nobs)) ! nobs=0 ! reuse counter head=1 jvar=0 - ! ! count '------' in history.rc as special markers for ngeoval ! @@ -187,9 +187,9 @@ ! 1-item case: file template or one-var ! 2-item : var1 , 'root' case STR1=trim(word(1)) - else - ! 3-item : var1 , 'root', var1_alias case - STR1=trim(word(M)) + else + ! 3-item : var1 , 'root', var1_alias case + STR1=trim(word(M)) end if deallocate(word) if ( index(trim(STR1), '-----') == 0 ) then @@ -218,7 +218,7 @@ allocate (traj%obs(k)%file_handle) end if end do - + call lgr%debug('%a %i8', 'nobs_type=', traj%nobs_type) do i=1, traj%nobs_type call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & @@ -228,18 +228,19 @@ _ASSERT(j>0, '% is not found, template is wrong') traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) end do - + _RETURN(_SUCCESS) + 105 format (1x,a,2x,a) 106 format (1x,a,2x,i8) end procedure HistoryTrajectory_from_config - + ! !-- integrate both initialize and reinitialize ! - module procedure initialize + module procedure initialize_ integer :: status type(ESMF_Grid) :: grid type(variable) :: v @@ -251,7 +252,7 @@ if (.not. present(reinitialize)) then if(present(bundle)) this%bundle=bundle if(present(items)) this%items=items - if(present(timeInfo)) this%time_info=timeInfo + if(present(timeInfo)) this%time_info=timeInfo if (present(vdata)) then this%vdata=vdata else @@ -267,7 +268,7 @@ end do end if end if - + do k=1, this%nobs_type call this%vdata%append_vertical_metadata(this%obs(k)%metadata,this%bundle,_RC) end do @@ -278,7 +279,7 @@ call get_obsfile_Tbracket_from_epoch(currTime, & this%obsfile_start_time, this%obsfile_end_time, & this%obsfile_interval, this%epoch_frequency, & - this%obsfile_Ts_index, this%obsfile_Te_index, _RC) + this%obsfile_Ts_index, this%obsfile_Te_index, _RC) if (this%obsfile_Te_index < 0) then if (mapl_am_I_root()) then write(6,*) "model start time is earlier than obsfile_start_time" @@ -295,22 +296,22 @@ do k=1, this%nobs_type - call this%obs(k)%metadata%add_dimension(this%nc_index, this%obs(k)%nobs_epoch) + call this%obs(k)%metadata%add_dimension(this%index_name_x, this%obs(k)%nobs_epoch) if (this%time_info%integer_time) then - v = Variable(type=PFIO_INT32,dimensions=this%nc_index) + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) else - v = Variable(type=PFIO_REAL32,dimensions=this%nc_index) + v = Variable(type=PFIO_REAL32,dimensions=this%index_name_x) end if call v%add_attribute('units', this%datetime_units) call v%add_attribute('long_name', 'dateTime') call this%obs(k)%metadata%add_variable(this%var_name_time,v) - v = variable(type=PFIO_REAL64,dimensions=this%nc_index) + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_east') call v%add_attribute('long_name','longitude') call this%obs(k)%metadata%add_variable(this%var_name_lon,v) - v = variable(type=PFIO_REAL64,dimensions=this%nc_index) + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_north') call v%add_attribute('long_name','latitude') call this%obs(k)%metadata%add_variable(this%var_name_lat,v) @@ -331,7 +332,7 @@ _RETURN(_SUCCESS) - end procedure initialize + end procedure initialize_ @@ -358,9 +359,9 @@ units = 'unknown' endif if (field_rank==2) then - vdims = this%nc_index + vdims = this%index_name_x else if (field_rank==3) then - vdims = trim(this%nc_index)//",lev" + vdims = trim(this%index_name_x)//",lev" end if v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) call v%add_attribute('units',trim(units)) @@ -409,7 +410,7 @@ end if call MAPL_FieldBundleAdd(new_bundle,dst_field,_RC) else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") +!! _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo @@ -419,24 +420,33 @@ module procedure create_file_handle + use pflogger, only : Logger, logging integer :: status integer :: k character(len=ESMF_MAXSTR) :: filename + type(Logger), pointer :: lgr - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + lgr => logging%get_logger('HISTORY.sampler') do k=1, this%nobs_type - call this%obs(k)%metadata%modify_dimension(this%nc_index, this%obs(k)%nobs_epoch) + call this%obs(k)%metadata%modify_dimension(this%index_name_x, this%obs(k)%nobs_epoch) enddo if (mapl_am_I_root()) then do k=1, this%nobs_type if (this%obs(k)%nobs_epoch > 0) then filename=trim(this%obs(k)%name)//trim(filename_suffix) + call lgr%debug('%a %a', & + "Sampling to new file : ",trim(filename)) call this%obs(k)%file_handle%create(trim(filename),_RC) call this%obs(k)%file_handle%write(this%obs(k)%metadata,_RC) - write(6,*) "Sampling to new file : ",trim(filename) end if enddo end if @@ -449,10 +459,15 @@ integer :: status integer :: k - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + if (mapl_am_I_root()) then do k=1, this%nobs_type if (this%obs(k)%nobs_epoch > 0) then @@ -475,6 +490,7 @@ character(len=ESMF_MAXSTR) :: grp_name character(len=ESMF_MAXSTR) :: timeunits_file + character :: new_char(ESMF_MAXSTR) real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) real(kind=REAL64), allocatable :: times_R8_full(:) @@ -489,7 +505,7 @@ type(ESMF_VM) :: vm integer :: mypet, petcount - integer :: i, j, k, L + integer :: i, j, k, L, ii, jj integer :: fid_s, fid_e integer(kind=ESMF_KIND_I8) :: j0, j1 integer(kind=ESMF_KIND_I8) :: jt1, jt2 @@ -500,117 +516,184 @@ integer :: sec integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch integer :: nx2 + logical :: EX ! file + logical :: zero_obs - - this%datetime_units = "seconds since 1970-01-01 00:00:00" +!! this%datetime_units = "seconds since 1970-01-01 00:00:00" lgr => logging%get_logger('HISTORY.sampler') call ESMF_VMGetGlobal(vm,_RC) call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - if (this%nc_index == '') then + if (this%index_name_x == '') then ! - !-- non IODA case + !-- non IODA case / non netCDF ! _FAIL('non-IODA format is not implemented here') + end if + + ! + !-- IODA case + ! + i=index(this%var_name_lon_full, '/') + if (i==0) then + grp_name = '' + call lgr%debug('%a', 'grp_name not found') else - ! - !-- IODA case - ! - i=index(this%nc_longitude, '/') - _ASSERT (i>0, 'group name not found') - grp_name = this%nc_longitude(1:i-1) - this%var_name_lon = this%nc_longitude(i+1:) - i=index(this%nc_latitude, '/') - this%var_name_lat = this%nc_latitude(i+1:) - i=index(this%nc_time, '/') - this%var_name_time= this%nc_time(i+1:) - - call lgr%debug('%a', 'grp_name,this%var_name_lat,this%var_name_lon,this%var_name_time') - call lgr%debug('%a %a %a %a', & - trim(grp_name),trim(this%var_name_lat),trim(this%var_name_lon),trim(this%var_name_time)) - - L=0 - fid_s=this%obsfile_Ts_index - fid_e=this%obsfile_Te_index - if(fid_e < L) then - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - this%epoch_index(1:2) = 0 - this%nobs_epoch = 0 - rc = 0 - return - end if + grp_name = this%var_name_lon_full(1:i-1) + end if + this%var_name_lon = this%var_name_lon_full(i+1:) + i=index(this%var_name_lat_full, '/') + this%var_name_lat = this%var_name_lat_full(i+1:) + i=index(this%var_name_time_full, '/') + this%var_name_time= this%var_name_time_full(i+1:) - if (mapl_am_I_root()) then - len = 0 - do k=1, this%nobs_type - j = max (fid_s, L) - do while (j<=fid_e) - filename = get_filename_from_template_use_index( & - this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, _RC) - if (filename /= '') then - call lgr%debug('%a %a', 'true filename: ', trim(filename)) - call get_ncfile_dimension(filename, tdim=num_times, key_time=this%nc_index, _RC) - len = len + num_times - end if - j=j+1 - enddo + call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') + call lgr%debug('%a %a %a %a %a', & + trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& + trim(this%var_name_lat),trim(this%var_name_time)) + + L=0 + fid_s=this%obsfile_Ts_index + fid_e=this%obsfile_Te_index + + call lgr%debug('%a %i10 %i10', & + 'fid_s, fid_e', fid_s, fid_e) + + arr(1)=0 ! len_full + if (mapl_am_I_root()) then + len = 0 + do k=1, this%nobs_type + j = max (fid_s, L) + do while (j<=fid_e) + filename = get_filename_from_template_use_index( & + this%obsfile_start_time, this%obsfile_interval, & + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + call lgr%debug('%a %i10', 'exist: filename fid j :', j) + call lgr%debug('%a %a', 'exist: true filename :', trim(filename)) + call get_ncfile_dimension(filename, tdim=num_times, key_time=this%index_name_x, _RC) + len = len + num_times + else + call lgr%debug('%a %i10', 'non-exist: filename fid j :', j) + call lgr%debug('%a %a', 'non-exist: missing filename:', trim(filename)) + end if + j=j+1 enddo - len_full = len + enddo + arr(1)=len + + if (len>0) then allocate(lons_full(len),lats_full(len),_STAT) allocate(times_R8_full(len),_STAT) allocate(obstype_id_full(len),_STAT) - call lgr%debug('%a %i12', 'nobs from input file:', len_full) - + call lgr%debug('%a %i12', 'nobs from input file:', len) len = 0 + ii = 0 do k=1, this%nobs_type j = max (fid_s, L) do while (j<=fid_e) filename = get_filename_from_template_use_index( & this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, _RC) - if (filename /= '') then - call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%nc_index, _RC) + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + ii = ii + 1 + call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%index_name_x, _RC) call get_v1d_netcdf_R8 (filename, this%var_name_lon, lons_full(len+1:), num_times, group_name=grp_name) call get_v1d_netcdf_R8 (filename, this%var_name_lat, lats_full(len+1:), num_times, group_name=grp_name) call get_v1d_netcdf_R8 (filename, this%var_name_time, times_R8_full(len+1:), num_times, group_name=grp_name) - call get_attribute_from_group (filename, grp_name, this%var_name_time, "units", timeunits_file) + if (ii == 1) then + this%datetime_units = trim(timeunits_file) + call lgr%debug('%a %a', 'datetime_units from 1st file:', trim(timeunits_file)) + end if obstype_id_full(len+1:len+num_times) = k - call lgr%debug('%a %f25.12, %f25.12', 'times_R8_full(1:200:100)', & - times_R8_full(1), times_R8_full(200)) - + !!write(6,'(f12.2)') times_R8_full(::50) len = len + num_times end if j=j+1 enddo enddo end if + end if + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (nx_sum == 0) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2) = 0 + this%nobs_epoch = 0 + this%nobs_epoch_sum = 0 + ! + ! empty shell to keep regridding and destroy_RH_LS to work + ! + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + this%obsTime= -1.d0 - if (mapl_am_I_root()) then - call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) - call ESMF_ClockGet(this%clock,currTime=current_time,_RC) - timeset(1) = current_time - timeset(2) = current_time + this%epoch_frequency - call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) - sec = hms_2_s(this%Epoch) - j1 = j0 + int(sec, kind=ESMF_KIND_I8) - jx0 = real ( j0, kind=ESMF_KIND_R8) - jx1 = real ( j1, kind=ESMF_KIND_R8) - - nstart=1; nend=size(times_R8_full) - call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - if (jt1==jt2) then - _FAIL('Epoch Time is too small, empty swath grid is generated, increase Epoch') - endif - call lgr%debug ('%a %f20.1 %f20.1', 'jx0, jx1', jx0, jx1) - call lgr%debug ('%a %i20 %i20', 'jt1, jt2', jt1, jt2) + call lgr%debug('%a %i5', 'nobservation points=', nx_sum) + rc = 0 + return + end if + call MAPL_CommsBcast(vm, this%datetime_units, N=ESMF_MAXSTR, ROOT=MAPL_Root, _RC) + + + if (mapl_am_I_root()) then + ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time + call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) + timeset(1) = current_time + timeset(2) = current_time + this%epoch_frequency + call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) + sec = hms_2_s(this%Epoch) + j1 = j0 + int(sec, kind=ESMF_KIND_I8) + jx0 = real ( j0, kind=ESMF_KIND_R8) + jx1 = real ( j1, kind=ESMF_KIND_R8) + + nstart=1; nend=size(times_R8_full) + call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + times_R8_full(1), times_R8_full(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) + + +! if (jt1==jt2) then +! _FAIL('Epoch Time is too small, empty grid is generated, increase Epoch') +! endif + + !-- shift the zero item to index 1 + zero_obs = .false. + if (jt1/=jt2) then + zero_obs = .false. + if (jt1==0) jt1=1 + else + ! at most one obs point exist, set it .true. + zero_obs = .true. + !! if (jt1==0) jt1=1 + end if + + ! + !-- exclude the out-of-range case + ! + if ( zero_obs ) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + else ! (x1, x2] design in bisect if (jt1==0) then this%epoch_index(1)= 1 @@ -626,6 +709,8 @@ nx= this%epoch_index(2) - this%epoch_index(1) + 1 this%nobs_epoch = nx + + allocate(this%lons(nx),this%lats(nx),_STAT) allocate(this%times_R8(nx),_STAT) allocate(this%obstype_id(nx),_STAT) @@ -679,47 +764,46 @@ call lgr%debug('%a %i4 %a %i12', & 'obs(', k, ')%nobs_epoch', this%obs(k)%nobs_epoch ) enddo + end if + else + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + endif - else - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - this%epoch_index(1:2)=0 - this%nobs_epoch = 0 - nx=0 - arr(1)=nx - endif - - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & - count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) - this%nobs_epoch_sum = nx_sum - if (mapl_am_I_root()) write(6,*) 'nobs in Epoch :', nx_sum + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + this%nobs_epoch_sum = nx_sum + if (mapl_am_I_root()) write(6,'(2x,a,2x,i15)') 'nobs in Epoch :', nx_sum - this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) - this%LS_rt = this%locstream_factory%create_locstream(_RC) - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) - this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) - this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) - call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) - call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) - if (mypet == 0) then - ptAT(:) = this%times_R8(:) - end if - this%obsTime= -1.d0 + call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + if (mypet == 0) then + ptAT(:) = this%times_R8(:) + end if + this%obsTime= -1.d0 - call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) - call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) + call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) + call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) - !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) + !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) - ! defer destroy fieldB at regen_grid step - ! - end if + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) + ! defer destroy fieldB at regen_grid step + ! _RETURN(_SUCCESS) @@ -746,7 +830,7 @@ integer :: j, k, ig integer, allocatable :: ix(:) - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif @@ -835,6 +919,9 @@ enddo endif enddo + do k=1, this%nobs_type + deallocate (this%obs(k)%p2d) + enddo end if else if (rank==2) then call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) @@ -878,7 +965,7 @@ nx = this%obs(k)%nobs_epoch if (nx>0) then do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then 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 @@ -889,6 +976,10 @@ !!write(6,*) 'here in append_file: put_var 3d' !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + !! + do k=1, this%nobs_type + deallocate (this%obs(k)%p3d) + enddo end if endif else if (item%itemType == ItemTypeVector) then @@ -919,10 +1010,18 @@ real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - integer :: is, ie + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: is, ie, nx_sum integer :: status + integer :: arr(1) + + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif - if (.NOT. this%is_valid) then + if (this%nobs_epoch_sum==0) then _RETURN(ESMF_SUCCESS) endif @@ -933,6 +1032,27 @@ call this%get_x_subset(timeset, x_subset, _RC) is=x_subset(1) ie=x_subset(2) + !! write(6,'(2x,a,4i10)') 'in regrid_accumulate is, ie=', is, ie + + + ! + ! __ I designed a method to return from regridding if no valid points exist + ! in reality for 29 jedi platforms and dt > 20 sec, we donot need this + ! + !!arr(1)=1 + !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 + !!call ESMF_VMGetGlobal(vm,_RC) + !!call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) + !!call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + !! count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + !!if ( nx_sum == 0 ) then + !! write(6, '(2x,a,2x,3i10)') 'invalid points, mypet, is, ie =', mypet, is, ie + !! ! no valid points to regrid + !! _RETURN(ESMF_SUCCESS) + !!else + !! write(6, '(2x,a,2x,3i10)') ' valid points, mypet, is, ie =', mypet, is, ie + !!end if + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then call this%vdata%setup_eta_to_pressure(_RC) @@ -996,7 +1116,7 @@ type(ESMF_Field) :: field type(ESMF_Time) :: currTime - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif @@ -1016,9 +1136,15 @@ if (mapl_am_i_root()) then do k=1, this%nobs_type - deallocate (this%obs(k)%lons) - deallocate (this%obs(k)%lats) - deallocate (this%obs(k)%times_R8) + if (allocated (this%obs(k)%lons)) then + deallocate (this%obs(k)%lons) + end if + if (allocated (this%obs(k)%lats)) then + deallocate (this%obs(k)%lats) + end if + if (allocated (this%obs(k)%times_R8)) then + deallocate (this%obs(k)%times_R8) + end if if (allocated(this%obs(k)%p2d)) then deallocate (this%obs(k)%p2d) endif @@ -1049,7 +1175,7 @@ call ESMF_ClockGet ( this%clock, CurrTime=currTime, _RC ) if (currTime > this%obsfile_end_time) then - this%is_valid = .false. + this%active = .false. _RETURN(ESMF_SUCCESS) end if @@ -1067,7 +1193,7 @@ real (ESMF_KIND_R8) :: rT1, rT2 integer(ESMF_KIND_I8) :: i1, i2 - integer(ESMF_KIND_I8) :: jt1, jt2, lb, ub + integer(ESMF_KIND_I8) :: index1, index2, lb, ub integer :: jlo, jhi integer :: status @@ -1078,7 +1204,9 @@ rT1=real(i1, kind=ESMF_KIND_R8) rT2=real(i2, kind=ESMF_KIND_R8) jlo = 1 - jhi= size(this%obstime) + !! + !! I choose UB = N+1 not N, because my sub. bisect find n: Y(n)=ub) then - x_subset(1) = lb - x_subset(2) = ub - else - x_subset(1) = lb - x_subset(2) = jt2 - endif - elseif (jt1>=ub) then - x_subset(1) = 0 - x_subset(2) = 0 - else - x_subset(1) = jt1 - if (jt2>=ub) then - x_subset(2) = ub - else - x_subset(2) = jt2 - endif - endif - + call bisect( this%obstime, rT1, index1, n_LB=lb, n_UB=ub, rc=rc) + call bisect( this%obstime, rT2, index2, n_LB=lb, n_UB=ub, rc=rc) + + ! (x1, x2] design in bisect + ! simple version + + x_subset(1) = index1+1 + x_subset(2) = index2 + +! if (index1=ub) then +! x_subset(2) = ub +! else +! x_subset(2) = index2 +! endif +! elseif (index1>=ub) then +! x_subset(1) = 0 +! x_subset(2) = 0 +! else +! x_subset(2) = index2 +! endif +! +!! write(6,'(2x,a,2x,2i10)') 'mod vers. get_x_subset, LB,UB=', x_subset(1:2) _RETURN(_SUCCESS) end procedure get_x_subset diff --git a/gridcomps/Orbit/CMakeLists.txt b/gridcomps/Orbit/CMakeLists.txt index b33c4f37778b..ed51cb1e23cb 100644 --- a/gridcomps/Orbit/CMakeLists.txt +++ b/gridcomps/Orbit/CMakeLists.txt @@ -5,7 +5,7 @@ set (srcs ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/griddedio/CMakeLists.txt b/griddedio/CMakeLists.txt index 1721226ab822..db7322918aef 100644 --- a/griddedio/CMakeLists.txt +++ b/griddedio/CMakeLists.txt @@ -12,7 +12,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.pfio MAPL_cfio_r4 TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/griddedio/TileIO.F90 b/griddedio/TileIO.F90 index 7b55aca9609c..88a5a518c1d5 100644 --- a/griddedio/TileIO.F90 +++ b/griddedio/TileIO.F90 @@ -12,6 +12,10 @@ module MAPL_TileIOMod private + type tile_buffer + real, allocatable :: ptr(:) + end type + type, public :: MAPL_TileIO private type(ESMF_FieldBundle) :: bundle @@ -22,10 +26,6 @@ module MAPL_TileIOMod procedure :: process_data_from_file end type MAPL_TileIO - type tile_buffer - real, allocatable :: ptr(:) - end type - interface MAPL_TileIO module procedure new_MAPL_TileIO end interface MAPL_TileIO @@ -40,13 +40,13 @@ function new_MAPL_TileIO(bundle,read_collection_id) result(TileIO) TileIO%bundle = bundle TileIO%read_collection_id = read_collection_id end function - + subroutine request_data_from_file(this,filename,timeindex,rc) class(MAPL_TileIO), intent(inout) :: this character(len=*), intent(in) :: filename integer, intent(in) :: timeindex integer, intent(out), optional :: rc - + integer :: status integer :: num_vars,i,rank type(ArrayReference) :: ref @@ -76,10 +76,10 @@ subroutine request_data_from_file(this,filename,timeindex,rc) allocate(this%tile_buffer(i)%ptr((0)),_STAT) end if ref = ArrayReference(this%tile_buffer(i)%ptr) - call i_clients%collective_prefetch_data(this%read_collection_id, filename, trim(names(i)), ref, & + call i_clients%collective_prefetch_data(this%read_collection_id, filename, trim(names(i)), ref, & start=local_start, global_start=global_start, global_count = global_count) - deallocate(local_start,global_start,global_count) - else + deallocate(local_start,global_start,global_count) + else _FAIL("rank >1 tile fields not supported") end if end do @@ -117,5 +117,5 @@ subroutine process_data_from_file(this,rc) deallocate(this%tile_buffer) _RETURN(_SUCCESS) end subroutine - + end module diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 6af1d06b6d7d..f85647b4a163 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -21,7 +21,7 @@ set (srcs FileMetadata.F90 FileMetadataVector.F90 NetCDF4_FileFormatter.F90 - pfio_get_att_string.c + pfio_nf90_supplement.c NetCDF_Supplement.F90 pFIO_Utilities.F90 pFIO.F90 diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 7a16331ada8e..26b894e39b44 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -43,7 +43,6 @@ module pFIO_NetCDF4_FileFormatterMod #include "new_overload.macro" - procedure :: ___SUB(get_var,string,0) procedure :: ___SUB(get_var,string,1) procedure :: ___SUB(get_var,int32,0) @@ -67,7 +66,6 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(get_var,real64,3) procedure :: ___SUB(get_var,real64,4) - procedure :: ___SUB(put_var,string,0) procedure :: ___SUB(put_var,string,1) procedure :: ___SUB(put_var,int32,0) procedure :: ___SUB(put_var,int32,1) @@ -91,7 +89,6 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(put_var,real64,4) - generic :: get_var => ___SUB(get_var,string,0) generic :: get_var => ___SUB(get_var,string,1) generic :: get_var => ___SUB(get_var,int32,0) generic :: get_var => ___SUB(get_var,int32,1) @@ -114,7 +111,6 @@ module pFIO_NetCDF4_FileFormatterMod generic :: get_var => ___SUB(get_var,real64,3) generic :: get_var => ___SUB(get_var,real64,4) - generic :: put_var => ___SUB(put_var,string,0) generic :: put_var => ___SUB(put_var,string,1) generic :: put_var => ___SUB(put_var,int32,0) generic :: put_var => ___SUB(put_var,int32,1) @@ -139,6 +135,7 @@ module pFIO_NetCDF4_FileFormatterMod #include "undo_overload.macro" + procedure :: inq_var_string_length procedure, private :: def_dimensions procedure, private :: put_attributes procedure, private :: put_var_attributes @@ -751,9 +748,12 @@ subroutine def_variables(this, cf, unusable, varname, rc) status = nf90_def_var(this%ncid, var_name, xtype, dimids, varid) !$omp end critical _VERIFY(status) - !$omp critical - status = nf90_def_var_fill(this%ncid, varid, NF90_NOFILL, 0) - !$omp end critical + ! There is no nf90 interface for string. skip the fill + if (xtype /=12) then + !$omp critical + status = nf90_def_var_fill(this%ncid, varid, NF90_NOFILL, 0) + !$omp end critical + endif _VERIFY(status) chunksizes => var%get_chunksizes() if (size(chunksizes) > 0) then @@ -1092,6 +1092,21 @@ subroutine inq_var_attributes(this, var, varid, unusable, rc) _UNUSED_DUMMY(unusable) end subroutine inq_var_attributes + subroutine inq_var_string_length(this, var_name, length, unusable, rc) + class (NetCDF4_FileFormatter), intent(inout) :: this + character(*), intent(in) :: var_name + integer, intent(out) :: length + class (KeywordEnforcer), optional, intent(in):: unusable + integer, optional, intent(out) :: rc + + integer :: varid, status + + status = nf90_inq_varid(this%ncid, name=var_name, varid=varid) + _VERIFY(status) + status = pfio_nf90_get_var_string_len(this%ncid, varid, length) + _VERIFY(status) + _RETURN(_SUCCESS) + end subroutine inq_var_string_length subroutine inq_variables(this, cf, unusable, rc) class (NetCDF4_FileFormatter), intent(inout) :: this @@ -1315,10 +1330,6 @@ end subroutine inq_variables ! string #define _VARTYPE 0 -# define _RANK 0 -# include "NetCDF4_get_var.H" -# include "NetCDF4_put_var.H" -# undef _RANK # define _RANK 1 # include "NetCDF4_get_var.H" # include "NetCDF4_put_var.H" diff --git a/pfio/NetCDF4_get_var.H b/pfio/NetCDF4_get_var.H index 874d3d5c8671..48f252828027 100644 --- a/pfio/NetCDF4_get_var.H +++ b/pfio/NetCDF4_get_var.H @@ -36,10 +36,20 @@ _ASSERT(status==0,"Variable not found: "//trim(var_name)//" in file: "//trim(this%origin_file)) !$omp critical +#if (_VARTYPE == 0) + +#if (_RANK == 1) + ! only support rank 1 of string + status = pfio_nf90_get_var_string(ncid, varid, values, start, count) +#endif + +#else + #if (_RANK == 0) status = nf90_get_var(ncid, varid, values) #else status = nf90_get_var(ncid, varid, values, start, count) +#endif #endif !$omp end critical _ASSERT(status==0,"Unable to get variable: "//trim(var_name)//" from file: "//trim(this%origin_file)) diff --git a/pfio/NetCDF4_put_var.H b/pfio/NetCDF4_put_var.H index 6a43e824c406..1c5a2eb52f46 100644 --- a/pfio/NetCDF4_put_var.H +++ b/pfio/NetCDF4_put_var.H @@ -22,16 +22,25 @@ integer :: status integer :: varid - !$omp critical status = nf90_inq_varid(this%ncid, name=var_name, varid=varid) !$omp end critical _VERIFY(status) !$omp critical +#if (_VARTYPE == 0) + +#if (_RANK == 1) + ! only support 1d string + status = pfio_nf90_put_var_string(this%ncid, varid, values, start, count) +#endif + +#else + #if (_RANK == 0) status = nf90_put_var(this%ncid, varid, values) #else status = nf90_put_var(this%ncid, varid, values, start, count) +#endif #endif !$omp end critical _VERIFY(status) diff --git a/pfio/NetCDF_Supplement.F90 b/pfio/NetCDF_Supplement.F90 index cb406f9d04fc..c9de2f26417c 100644 --- a/pfio/NetCDF_Supplement.F90 +++ b/pfio/NetCDF_Supplement.F90 @@ -7,6 +7,10 @@ module pfio_NetCDF_Supplement private public :: pfio_get_att_string + public :: pfio_nf90_put_var_string + public :: pfio_nf90_get_var_string + public :: pfio_nf90_get_var_string_len + interface function c_f_pfio_get_att_string(ncid, varid, name, string, attlen) & & result(stat) bind(C, name='pfio_get_att_string') @@ -19,6 +23,45 @@ function c_f_pfio_get_att_string(ncid, varid, name, string, attlen) & character(kind=C_CHAR), intent(inout) :: string(*) integer(kind=C_INT), intent(inout) :: attlen end function c_f_pfio_get_att_string + + function c_f_pfio_get_var_string_len(ncid, varid, str_len_ptr, size) & + & result(stat) bind(C, name='pfio_get_var_string_len') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), value, intent(in) :: str_len_ptr + integer(kind=C_INT), value, intent(in) :: size + end function c_f_pfio_get_var_string_len + + function c_f_pfio_get_var_string(ncid, varid, string_ptr, str_len, start_ptr, count_ptr) & + & result(stat) bind(C, name='pfio_get_var_string') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), intent(in), value :: string_ptr + integer(kind=C_INT), value, intent(in) :: str_len + type(c_ptr), intent(in), value :: start_ptr + type(c_ptr), intent(in), value :: count_ptr + end function c_f_pfio_get_var_string + + function c_f_pfio_put_var_string(ncid, varid, string_ptr, str_len, str_size, start_ptr, count_ptr) & + & result(stat) bind(C, name='pfio_put_var_string') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), intent(in), value :: string_ptr + integer(kind=C_INT), value, intent(in) :: str_len + integer(kind=C_INT), value, intent(in) :: str_size + type(c_ptr), intent(in), value :: start_ptr + type(c_ptr), intent(in), value :: count_ptr + end function c_f_pfio_put_var_string + end interface contains @@ -48,4 +91,79 @@ function pfio_get_att_string(ncid, varid, name, string) result(status) deallocate(c_name) end function pfio_get_att_string + function pfio_nf90_get_var_string(ncid, varid, string, start, count) result(status) + integer :: status + integer(kind=C_INT), intent(in) :: ncid + integer(kind=C_INT), intent(in) :: varid + character(*), target,intent(inout):: string(:) + integer, optional, intent(in) :: start(:) + integer, optional, intent(in) :: count(:) + integer, target, allocatable :: start_(:), count_(:) + integer :: str_len, str_size + + str_len = len(string(1)) + str_size = size(string) + if (.not. present(start) .or. .not. present(count)) then + allocate(start_(1), count_(1)) + start_(1) = 1 + count_(1) = str_size + else + start_ = start + count_ = count + endif + status = c_f_pfio_get_var_string(ncid, varid, c_loc(string), str_len, c_loc(start_), c_loc(count_)) + deallocate(start_, count_) + + end function pfio_nf90_get_var_string + + function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(status) + integer :: status + integer(kind=C_INT), intent(in) :: ncid + integer(kind=C_INT), intent(in) :: varid + character(*), target,intent(in):: string(:) + integer, optional, intent(in) :: start(:) + integer, optional, intent(in) :: count(:) + integer, target, allocatable :: start_(:), count_(:) + integer :: max_len, str_size, k + character(len=:),allocatable, target :: string_C(:) + + max_len = len(string(1)) + 1 + str_size = size(string) + if (.not. present(start) .or. .not. present(count)) then + allocate(start_(1), count_(1)) + start_(1) = 1 + count_(1) = str_size + else + start_ = start + count_ = count + endif + + allocate(character(len=max_len) :: string_C(str_size)) + do k = 1, str_size + string_C(k) = trim(adjustl(string(k)))//c_null_char + enddo + + status = c_f_pfio_put_var_string(ncid, varid, c_loc(string_C), max_len, str_size, c_loc(start_), c_loc(count_)) + deallocate(start_, count_) + deallocate(string_C) + end function pfio_nf90_put_var_string + + function pfio_nf90_get_var_string_len(ncid, varid, str_len) result(status) + use netcdf + integer :: status + integer, intent(in) :: ncid + integer, intent(in) :: varid + integer, intent(out):: str_len + integer, allocatable :: dimids(:) + integer :: size + integer, target :: length + + allocate(dimids(1)) + status = nf90_inquire_variable(ncid, varid, dimids=dimids) + status = nf90_inquire_dimension(ncid, dimids(1), len=size) + status = c_f_pfio_get_var_string_len(ncid, varid, c_loc(length), size) + str_len = length + + end function pfio_nf90_get_var_string_len + end module pfio_NetCDF_Supplement diff --git a/pfio/pfio_get_att_string.c b/pfio/pfio_get_att_string.c deleted file mode 100644 index 6b7b8475774e..000000000000 --- a/pfio/pfio_get_att_string.c +++ /dev/null @@ -1,51 +0,0 @@ -#include -#include -#include -#include - -void pfio_check(int stat) { - if (stat != NC_NOERR) { - printf("NetCDF error: %s\n", nc_strerror(stat)); - exit(1); - } -} - -int pfio_get_att_string(int ncid, int varid, const char* name, char* value, int *attlen) -{ - int stat; - size_t alen; - - /* note: C-varid starts from 0, Fortran from 1 */ - int varid_C = varid - 1; - - stat = nc_inq_attlen(ncid, varid_C, name, &alen); pfio_check(stat); - - if (alen > 1) { - printf("pfio doesnot support multi-dimentional strings"); - exit(-1); - } - - char **string_attr = (char**)malloc( sizeof(char*)); - memset(string_attr, 0, sizeof(char*)); - - stat = nc_get_att_string(ncid, varid_C, name, string_attr); pfio_check(stat); - - *attlen = 0; - alen = 0; - char *p = string_attr[0]; - for(;;){ - if (alen >=511) { - printf("pfio doesnot support string longer than 512"); - exit(-1); - } - *(value+alen) = (*(p+alen)); - if (*(p + alen) == '\0'){ - break; - } - alen = alen + 1; - } - *attlen = alen; - stat = nc_free_string(1, string_attr); pfio_check(stat); - free(string_attr); - return stat; -} diff --git a/pfio/pfio_nf90_supplement.c b/pfio/pfio_nf90_supplement.c new file mode 100644 index 000000000000..6237102a2a29 --- /dev/null +++ b/pfio/pfio_nf90_supplement.c @@ -0,0 +1,141 @@ +#include +#include +#include +#include + +void pfio_check(int stat) { + if (stat != NC_NOERR) { + printf("NetCDF error: %s\n", nc_strerror(stat)); + exit(1); + } +} + +int pfio_get_att_string(int ncid, int varid, const char* name, char* value, int *attlen) +{ + int stat; + size_t alen; + + /* note: C-varid starts from 0, Fortran from 1 */ + int varid_C = varid - 1; + + stat = nc_inq_attlen(ncid, varid_C, name, &alen); pfio_check(stat); + + if (alen > 1) { + printf("pfio doesnot support multi-dimentional strings"); + exit(-1); + } + + char **string_attr = (char**)malloc( sizeof(char*)); + memset(string_attr, 0, sizeof(char*)); + + stat = nc_get_att_string(ncid, varid_C, name, string_attr); pfio_check(stat); + + *attlen = 0; + alen = 0; + char *p = string_attr[0]; + for(;;){ + if (alen >=511) { + printf("pfio doesnot support string longer than 512"); + exit(-1); + } + *(value+alen) = (*(p+alen)); + if (*(p + alen) == '\0'){ + break; + } + alen = alen + 1; + } + *attlen = alen; + stat = nc_free_string(1, string_attr); pfio_check(stat); + free(string_attr); + return stat; +} + +// +int pfio_get_var_string_len(int ncid, int varid, int *str_len, int str_size) +{ + int stat; + + // note: C-varid starts from 0, Fortran from 1 + int varid_C = varid - 1; + char *string[str_size]; + stat = nc_get_var(ncid, varid_C, string ); pfio_check(stat); + + char *p ; + int i, j; + *str_len = 0; + for (i = 0; i