diff --git a/.circleci/config.yml b/.circleci/config.yml index 676783f94c67..0d50a8c5d870 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -16,8 +16,8 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 -baselibs_version: &baselibs_version v7.13.0 -bcs_version: &bcs_version v11.00.0 +baselibs_version: &baselibs_version v7.14.0 +bcs_version: &bcs_version v11.1.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: @@ -217,6 +217,7 @@ workflows: checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 + extra_cmake_options: "-DBUILD_WITH_FLAP=ON" build-and-publish-docker: when: diff --git a/.github/workflows/enforce-labels.yml b/.github/workflows/enforce-labels.yml index 6d4b98633162..86f4bb4e440b 100644 --- a/.github/workflows/enforce-labels.yml +++ b/.github/workflows/enforce-labels.yml @@ -8,7 +8,7 @@ jobs: require-label: runs-on: ubuntu-latest steps: - - uses: mheap/github-action-required-labels@v4 + - uses: mheap/github-action-required-labels@v5 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: @@ -21,7 +21,7 @@ jobs: blocking-label: runs-on: ubuntu-latest steps: - - uses: mheap/github-action-required-labels@v4 + - uses: mheap/github-action-required-labels@v5 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml index fd525b2a4b35..16409a0bf4c9 100644 --- a/.github/workflows/push-to-develop.yml +++ b/.github/workflows/push-to-develop.yml @@ -22,7 +22,10 @@ jobs: target_branch: release/MAPL-v3 label: automatic,MAPL3,Skip Changelog template: .github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md - get_diff: true + # Turning this to false until the action can get a fix for + # https://github.com/devops-infra/action-pull-request/issues/126 + #get_diff: true + get_diff: false assignee: ${{ github.actor }} old_string: "" new_string: ${{ github.event.commits[0].message }} diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index b73ba9bbbcfa..9fc137bb07da 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.13.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.14.0-openmpi_4.1.4-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 @@ -77,7 +77,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.13.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.14.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CHANGELOG.md b/CHANGELOG.md index c69effd0fff5..53d30a37ac5f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,71 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.40.0] - 2023-07-29 + +### Added + +- Add ability of ExtData to fill variables on MAPL "tile" grids. +- Added print of regrid method during History initialization +- Added ability to use an `ESMF.rc` file to pass in pre-`ESMF_Initialize` options to ESMF (see [ESMF Docs](https://earthsystemmodeling.org/docs/release/latest/ESMF_refdoc/node4.html#SECTION04024000000000000000) for allowed flags. + - NOTE: File *must* be called `ESMF.rc` +- Added ability to run ExtDataDriver.x on a MAPL "tile" grid +- Add ability to introduce a time-step delay in ExtDataDriver.x to simulate the timestep latency of a real model +- Added a MAPL\_Sleep function, equivalent to some vendor supplied but non-standard sleep function +- sampling IODA file with trajectory sampler (step-1): make it run +- Convert ExtData to use ESMF HConfig for YAML parsing rather than YaFYAML + - Set required ESMF version to 8.5.0 +- Add StationSamplerMod for station sampler +- Added ReplaceMetadata message and method to replace oserver's metadata +- Added field utilities to perform basic numeric operations on fields +- Update arithemetic parser to work with any rank and type of ESMF fields +- For ExtDataDriver.x only, added logging config to Tests/ExtDataDriverMod.F90 to enable Logger there +- Added new fill option and run mode for ExtDataDriver.x + +### Changed + +- Updates to GFE library dependency + - Require gFTL v1.10.0 + - Require gFTL-shared v1.6.1 + - Require fArgParse v1.5.0 + - Require pFlogger v1.9.5 + - Removed yaFyaml as dependency +- Updated programs using FLAP for command line parsing to use fArgParse instead +- Updated `components.yaml` to use Baselibs 7.14.0 + - ESMA_env v4.9.1 → v4.19.0 + - Baselibs 7.14.0 + - esmf v8.5.0 + - GFE v1.11.0 + - curl 8.2.1 + - HDF5 1.10.10 + - netCDF-C 4.9.2 + - netCDF-Fortran 4.6.1 + - CDO 2.2.1 + - NCO 5.1.7 + - Move to MPT 2.28 at NAS, and other various changes for TOSS4 at NAS + - Remove Haswell from `build.csh` + - ESMA_cmake v3.28.0 → v3.31.0 + - Clean up for TOSS4 changes at NAS + - Add `QUIET_DEBUG` flag + - Suppress some common warnings with Intel Debug +- Make the GEOSadas CI build separate as it often fails due to race conditions in GSI +- Update CI to use BCs v11.1.0 and Baselibs 7.14.0 +- Updates to support building MAPL with spack instead of Baselibs + - Add `FindESMF.cmake` file to `cmake` directory (as it can't easily be found via spack) + - Move `CMAKE_MODULE_PATH` append statement up to find `FindESMF.cmake` before we `find_package(ESMF)` + - Default `BUILD_WITH_FLAP` to `OFF` as we don't build it in spack + - Explicitly build GEOSadas in CI with `-DBUILD_WITH_FLAP=ON` as GEOSadas is still behind in moving to use fArgParse + +### Fixed + +- Created cubed-sphere grid factory with files split by face +- Removed unneeded and confusing default in History Grid Comp (see #2081) +- Fixes in CMake for fArgParse transition + +### Deprecated + +- Deprecate the use of FLAP for command line parsing in favor of fArgParse. FLAP support will be removed in MAPL 3 + ## [2.39.7] - 2023-07-18 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 566a48858a98..77c5469864d7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.39.7 + VERSION 2.40.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui @@ -58,6 +58,8 @@ if (NOT COMMAND esma) endif () +list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") + option (BUILD_SHARED_MAPL "Build shared MAPL libraries" ON) if (BUILD_SHARED_MAPL) set (MAPL_LIBRARY_TYPE SHARED) @@ -71,38 +73,40 @@ message (STATUS "Building MAPL as ${MAPL_LIBRARY_TYPE} libraries") # This would then populate the target already leading to find_package() # errors. if(NOT TARGET GFTL::gftl) - # MAPL currently requires at least GFTL 1.5.1 - find_package(GFTL 1.5.1 REQUIRED) + find_package(GFTL 1.10.0 REQUIRED) else() - if (GFTL_VERSION VERSION_LESS 1.5.1) - message(FATAL_ERROR "GFTL must be at least 1.5.1") + if (GFTL_VERSION VERSION_LESS 1.10.0) + message(FATAL_ERROR "gFTL must be at least 1.10.0") endif () endif() +message (STATUS "Found gFTL: ${GFTL_DIR} (found version ${GFTL_VERSION})") + if(NOT TARGET GFTL_SHARED::gftl-shared) - find_package(GFTL_SHARED REQUIRED) + # MAPL currently requires at least gFTL-shared 1.6.1 + find_package(GFTL_SHARED 1.6.1 REQUIRED) +else () + if (GFTL_SHARED_VERSION VERSION_LESS 1.6.1) + message(FATAL_ERROR "gFTL-shared must be at least 1.6.1") + endif () endif() +message (STATUS "Found gFTL-shared: ${GFTL_DIR} (found version ${GFTL_SHARED_VERSION})") option(BUILD_WITH_FARGPARSE "Use fArgParse for command line processing" ON) if(BUILD_WITH_FARGPARSE) if(NOT TARGET FARGPARSE::fargparse) - find_package(FARGPARSE 1.4.1 REQUIRED) + find_package(FARGPARSE 1.5.0 REQUIRED) else() - if (FARGPARSE_VERSION VERSION_LESS 1.4.1) - message(FATAL_ERROR "fArgParse must be at least 1.4.1") + if (FARGPARSE_VERSION VERSION_LESS 1.5.0) + message(FATAL_ERROR "fArgParse must be at least 1.5.0") endif () endif() + message (STATUS "Building with fArgParse") + message (STATUS "Found fArgParse: ${FARGPARSE_DIR} (found version ${FARGPARSE_VERSION})") endif() option(USE_EXTDATA2G "Use ExtData2G" ON) if(USE_EXTDATA2G) set (EXTDATA2G_TARGET "MAPL.ExtData2G" CACHE STRING "ExtData2G Target") - if(NOT TARGET YAFYAML::yafyaml) - find_package(YAFYAML 1.0.4 REQUIRED) - else() - if (YAFYAML_VERSION VERSION_LESS 1.0.4) - message(FATAL_ERROR "yaFyaml must be at least 1.0.4") - endif () - endif() message (STATUS "Building with ExtData2G") else() set (EXTDATA2G_TARGET "" CACHE STRING "ExtData2G Target") @@ -111,15 +115,17 @@ endif() option(BUILD_WITH_PFLOGGER "Build MAPL with pFlogger library support" ON) if (BUILD_WITH_PFLOGGER) if(NOT TARGET PFLOGGER::pflogger) - find_package(PFLOGGER 1.9.1 REQUIRED) + find_package(PFLOGGER 1.9.5 REQUIRED) else() - if (PFLOGGER_VERSION VERSION_LESS 1.9.1) - message(FATAL_ERROR "pFlogger must be at least 1.9.1") + if (PFLOGGER_VERSION VERSION_LESS 1.9.5) + message(FATAL_ERROR "pFlogger must be at least 1.9.5") endif () endif() + message (STATUS "Building with pFlogger") + message (STATUS "Found pFlogger: ${PFLOGGER_DIR} (found version ${PFLOGGER_VERSION})") endif() -option(BUILD_WITH_FLAP "Use FLAP for command line processing" ON) +option(BUILD_WITH_FLAP "Use FLAP for command line processing" OFF) if (BUILD_WITH_FLAP) find_package(FLAP REQUIRED) endif () @@ -142,7 +148,7 @@ if (NOT Baselibs_FOUND) endif() if (NOT TARGET esmf) - find_package(ESMF 8.4.0 MODULE REQUIRED) + find_package(ESMF 8.5.0 MODULE REQUIRED) # ESMF as used in MAPL requires MPI # NOTE: This looks odd because some versions of FindESMF.cmake out in the @@ -157,6 +163,13 @@ if (NOT Baselibs_FOUND) add_library(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") + endif () endif () # We wish to add extra flags when compiling as Debug. We should only @@ -209,7 +222,7 @@ add_subdirectory (base) add_subdirectory (MAPL) add_subdirectory (gridcomps) add_subdirectory (griddedio) -if (BUILD_WITH_FLAP) +if (BUILD_WITH_FARGPARSE) add_subdirectory (tutorial) endif() @@ -219,7 +232,6 @@ if (PFUNIT_FOUND) endif () # Support for automated code generation -list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") include(mapl_acg) include(mapl_create_stub_component) add_subdirectory (Apps) diff --git a/Ford/docs-with-remote-esmf.md b/Ford/docs-with-remote-esmf.md index f6758647794e..0cebe66900a0 100644 --- a/Ford/docs-with-remote-esmf.md +++ b/Ford/docs-with-remote-esmf.md @@ -21,7 +21,6 @@ exclude_dir: ../Ford ../build ../gFTL ../esmf - ../yaFyaml ../pFUnit ../fArgParse ../pFlogger diff --git a/Ford/docs-with-remote-esmf.public_private_protected.md b/Ford/docs-with-remote-esmf.public_private_protected.md index fdbcf328c2d2..7b0e96d4f8ef 100644 --- a/Ford/docs-with-remote-esmf.public_private_protected.md +++ b/Ford/docs-with-remote-esmf.public_private_protected.md @@ -22,7 +22,6 @@ exclude_dir: ../Ford ../build ../gFTL ../esmf - ../yaFyaml ../pFUnit ../fArgParse ../pFlogger diff --git a/MAPL/CMakeLists.txt b/MAPL/CMakeLists.txt index f49b1d486a46..052c4bc45f82 100644 --- a/MAPL/CMakeLists.txt +++ b/MAPL/CMakeLists.txt @@ -3,7 +3,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 ${EXTDATA_TARGET} + DEPENDENCIES MAPL.base MAPL.generic MAPL.pfio MAPL_cfio_r4 MAPL.gridcomps MAPL.orbit MAPL.griddedio MAPL.geom ${EXTDATA_TARGET} esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran $<$:FLAP::FLAP> TYPE ${MAPL_LIBRARY_TYPE} diff --git a/MAPL/MAPL.F90 b/MAPL/MAPL.F90 index 4636b37f5b38..87e83c64b8dc 100644 --- a/MAPL/MAPL.F90 +++ b/MAPL/MAPL.F90 @@ -15,6 +15,7 @@ module MAPL use MAPL_OpenMP_Support, only : MAPL_find_bounds => find_bounds use MAPL_OpenMP_Support, only : MAPL_Interval => Interval use MAPL_Profiler, initialize_profiler =>initialize, finalize_profiler =>finalize + use MAPL_Geom implicit none end module MAPL diff --git a/Tests/CMakeLists.txt b/Tests/CMakeLists.txt index 89bfe936b11b..d427e82a59c0 100644 --- a/Tests/CMakeLists.txt +++ b/Tests/CMakeLists.txt @@ -8,10 +8,10 @@ set (srcs VarspecDescription.F90 ) -if (BUILD_WITH_FLAP) +if (BUILD_WITH_FARGPARSE) ecbuild_add_executable (TARGET ExtDataDriver.x SOURCES ${srcs}) - target_link_libraries (ExtDataDriver.x PRIVATE MAPL FLAP::FLAP esmf) + target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse 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,17 +21,12 @@ if (BUILD_WITH_FLAP) 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 FLAP::FLAP esmf) + target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse 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}) - -endif () - -if (BUILD_WITH_FARGPARSE) - 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) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/Tests/ExtDataDriver.F90 b/Tests/ExtDataDriver.F90 index 71dc735c0102..ea7a061d0f0f 100644 --- a/Tests/ExtDataDriver.F90 +++ b/Tests/ExtDataDriver.F90 @@ -16,9 +16,9 @@ program ExtData_Driver character(len=*), parameter :: Iam="ExtData_Driver" type(ExtDataDriver) :: Driver type (MAPL_CapOptions) :: cap_options - type (MAPL_FlapCLI) :: cli + type (MAPL_FargparseCLI) :: cli - cli = MAPL_FlapCLI(description='extdata driver',authors='gmao') + cli = MAPL_FargparseCLI() cap_options=MAPL_CapOptions(cli) driver = ExtDataDriver('ExtDataApp',Root_SetServices,cap_options=cap_options,_RC) diff --git a/Tests/ExtDataDriverMod.F90 b/Tests/ExtDataDriverMod.F90 index c4f168d08c85..757398872933 100644 --- a/Tests/ExtDataDriverMod.F90 +++ b/Tests/ExtDataDriverMod.F90 @@ -58,7 +58,9 @@ function newExtDataDriver(name,set_services, unusable, cap_options, rc) result(d driver%cap_options = MAPL_CapOptions() endif call driver%initialize_mpi() - call MAPL_Initialize(comm=MPI_COMM_WORLD,rc=status) + call MAPL_Initialize(comm=MPI_COMM_WORLD, & + logging_config=driver%cap_options%logging_config, & + rc=status) _VERIFY(status) _RETURN(_SUCCESS) end function newExtDataDriver diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 838ecece3430..6bbe85200b62 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -1,13 +1,14 @@ - + !------------------------------------------------------------------------- ! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! !------------------------------------------------------------------------- ! #include "MAPL_Generic.h" - + MODULE ExtDataUtRoot_GridCompMod use ESMF use MAPL + use MAPLShared use VarspecDescriptionMod use VarspecDescriptionVectorMod use netcdf @@ -38,6 +39,8 @@ MODULE ExtDataUtRoot_GridCompMod type(StringStringMap) :: fillDefs character(len=ESMF_MAXSTR) :: runMode type(timeVar) :: tFunc + logical :: on_tiles + real :: delay ! in seconds end type SyntheticFieldSupport type :: SyntheticFieldSupportWrapper @@ -45,6 +48,7 @@ MODULE ExtDataUtRoot_GridCompMod end type SyntheticFieldSupportWrapper character(len=*), parameter :: runModeGenerateExports = "GenerateExports" + character(len=*), parameter :: runModeGenerateImports = "GenerateImports" character(len=*), parameter :: runModeCompareImports = "CompareImports" character(len=*), parameter :: runModeFillExportFromImport = "FillExportsFromImports" character(len=*), parameter :: runModeFillImport = "FillImport" @@ -65,6 +69,8 @@ subroutine SetServices ( GC, RC ) type(ESMF_Config) :: cf type(SyntheticFieldSupportWrapper) :: synthWrap type(SyntheticFieldSupport), pointer :: synth + logical :: on_tiles + integer :: vloc call ESMF_GridCompGet( GC, NAME=COMP_NAME, CONFIG=CF, _RC ) @@ -75,46 +81,60 @@ subroutine SetServices ( GC, RC ) synthWrap%ptr => synth call ESMF_UserCompSetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) + call ESMF_ConfigFindLabel(cf,"tiling_file:",isPresent=synth%on_tiles,_RC) + if (synth%on_tiles) then + vloc = MAPL_DimsTileOnly + else + vloc = MAPL_DimsHorzOnly + end if call AddState(GC,CF,"IMPORT",_RC) call AddState(GC,CF,"EXPORT",_RC) + call MAPL_AddInternalSpec(GC,& short_name='time', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='lats', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='lons', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='i_index', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='j_index', & long_name='na' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) call MAPL_AddInternalSpec(GC,& short_name='doy', & long_name='day_since_start_of_year' , & units = 'na', & - dims = MAPL_DimsHorzOnly, & + dims = vloc, & + vlocation = MAPL_VLocationNone, _RC) + call MAPL_AddInternalSpec(GC,& + short_name='rand', & + long_name='random number' , & + units = 'na', & + dims = vloc, & vlocation = MAPL_VLocationNone, _RC) + call MAPL_GenericSetServices ( GC, _RC) _RETURN(ESMF_SUCCESS) @@ -132,7 +152,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_State), intent(inout) :: EXPORT ! Export State integer, intent(out) :: rc ! Error return code: - type(ESMF_Config) :: CF ! Universal Config + type(ESMF_Config) :: CF ! Universal Config integer :: status character(len=ESMF_MAXSTR) :: comp_name @@ -145,14 +165,23 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(SyntheticFieldSupportWrapper) :: synthWrap type(SyntheticFieldSupport), pointer :: synth => null() character(len=ESMF_MaxStr) :: key, keyVal + type(MAPL_MetaComp), pointer :: MAPL + logical :: isPresent call ESMF_GridCompGet( GC, name=comp_name, config=CF, _RC ) + call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) synth => synthWrap%ptr call ESMF_ClockGet(Clock,currTime=currTime,_RC) + synth%delay = -1.0 + call ESMF_ConfigFindLabel(cf,label='delay:',isPresent=isPresent,_RC) + if (isPresent) then + call ESMF_ConfigGetAttribute(cf,label='delay:',value=synth%delay,_RC) + end if + call ESMF_ConfigGetDim(cf,nrows,ncolumn,label="FILL_DEF::",rc=status) if (status==ESMF_SUCCESS) then call ESMF_ConfigFindLabel(cf,label="FILL_DEF::",_RC) @@ -169,6 +198,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_GridCreate(GC, _RC) call ESMF_GridCompGet(GC, grid=grid, _RC) + call set_locstream(_RC) !allocate(ak(lm+1),stat=status) !allocate(bk(lm+1),stat=status) !call set_eta(lm,ls,ptop,pint,ak,bk) @@ -181,6 +211,30 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ForceAllocation(Export,_RC) _RETURN(ESMF_SUCCESS) + contains + + subroutine set_locstream(rc) + + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXPATHLEN) :: tile_file + type(ESMF_DistGrid) :: distgrid + type(ESMF_DELayout) :: layout + type(MAPL_LocStream) :: exch + + if (synth%on_tiles) then + call ESMF_ConfigGetAttribute(cf,tile_file,label="tiling_file:",_RC) + call ESMF_GridGet(grid,distGrid=distgrid,_RC) + call ESMF_DistGridGet(distgrid,deLayout=layout,_RC) + call MAPL_LocStreamCreate(exch,layout=layout,filename=tile_file, & + name = 'my_tiles', mask = [MAPL_LAND], grid=grid,_RC) + call MAPL_ExchangeGridSet(gc,exch,_RC) + call MAPL_GenericMakeXchgNatural(MAPL,_RC) + call ESMF_GridCompSet(gc,grid=grid,_RC) + end if + _RETURN(_SUCCESS) + end subroutine set_locstream END SUBROUTINE Initialize_ @@ -223,29 +277,38 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call ESMF_UserCompGetInternalState(gc,wrap_name,synthWrap,status) _VERIFY(status) synth => synthWrap%ptr - call ESMF_GridCompGet(GC,grid=grid,_RC) - call MAPL_GetPointer(internal,ptrR4,'lons',_RC) - call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=ptrR8, _RC) - ptrR4=ptrR8 - call MAPL_GetPointer(internal,ptrR4,'lats',_RC) - call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=ptrR8, _RC) - ptrR4=ptrR8 + if (synth%delay > -1.0) then + call MAPL_Sleep(synth%delay) + end if + if (.not. synth%on_tiles) then + call ESMF_GridCompGet(GC,grid=grid,_RC) + call MAPL_GetPointer(internal,ptrR4,'lons',_RC) + call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=ptrR8, _RC) + ptrR4=ptrR8 + call MAPL_GetPointer(internal,ptrR4,'lats',_RC) + call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=ptrR8, _RC) + ptrR4=ptrR8 + end if select case (trim(synth%runMode)) case(RunModeGenerateExports) - call FillState(internal,export,currTime,grid,synth,_RC) + call FillState(internal,export,currTime,grid,synth,_RC) + + case(RunModeGenerateImports) + + call FillState(internal,import,currTime,grid,synth,_RC) case(runModecompareImports) call FillState(internal,export,currTime,grid,synth,_RC) - call CompareState(import,export,0.001,_RC) + call CompareState(import,export,0.001,_RC) - case(runModeFillImport) + case(runModeFillImport) ! Nothing to do, we are just letting ExtData run case(runModeFillExportFromImport) @@ -353,7 +416,7 @@ function evaluate_time(this,currTime,rc) result(dt) class(timeVar), intent(in) :: this type(ESMF_Time), intent(inout) :: currTime integer, optional, intent(out) :: rc - real(REAL64) :: dt + real(kind=ESMF_KIND_R8) :: dt integer :: status @@ -367,9 +430,9 @@ function evaluate_time(this,currTime,rc) result(dt) call ESMF_TimeIntervalSet(yearInterval,yy=yint,_RC) currTime = currTime+yearInterval end if - periodic_time = this%set_time_for_date(currTime,_RC) + periodic_time = this%set_time_for_date(currTime,_RC) if (this%have_offset) then - timeInterval = periodic_time + this%update_offset - this%refTime + timeInterval = periodic_time + this%update_offset - this%refTime else timeInterval = periodic_time - this%refTime end if @@ -406,7 +469,7 @@ function set_time_for_date(this,input_time,rc) result(returned_time) returned_time = input_time else if (new_time < input_time) then returned_time = new_time - else if (new_time > input_time) then + else if (new_time > input_time) then call ESMF_TimeSet(new_time,yy=year,mm=month,dd=day-1,h=hour,m=minute,s=second,_RC) returned_time = new_time end if @@ -425,10 +488,12 @@ subroutine CopyState(inState,outState,rc) integer :: status integer :: I - real, pointer :: IMptr3(:,:,:) => null() - real, pointer :: Exptr3(:,:,:) => null() - real, pointer :: IMptr2(:,:) => null() - real, pointer :: Exptr2(:,:) => null() + real, pointer :: IMptr3(:,:,:) + real, pointer :: Exptr3(:,:,:) + real, pointer :: IMptr2(:,:) + real, pointer :: Exptr2(:,:) + real, pointer :: IMptr1(:) + real, pointer :: Exptr1(:) integer :: itemcountIn,itemCountOut,rank character(len=ESMF_MAXSTR), allocatable :: inNameList(:) character(len=ESMF_MAXSTR), allocatable :: outNameList(:) @@ -450,7 +515,11 @@ subroutine CopyState(inState,outState,rc) call ESMF_StateGet(inState,trim(inNameList(i)),impf,_RC) call ESMF_StateGet(outState,trim(outNameList(i)),expf,_RC) call ESMF_FieldGet(impf,rank=rank,_RC) - if (rank==2) then + if (rank==1) then + call MAPL_GetPointer(inState,IMptr1,inNameList(i),_RC) + call MAPL_GetPointer(outState,Exptr1,inNameList(i),alloc=.true.,_RC) + EXptr1=IMptr1 + else if (rank==2) then call MAPL_GetPointer(inState,IMptr2,inNameList(i),_RC) call MAPL_GetPointer(outState,Exptr2,inNameList(i),alloc=.true.,_RC) EXptr2=IMptr2 @@ -460,7 +529,7 @@ subroutine CopyState(inState,outState,rc) EXptr3=IMptr3 end if end do - deallocate(inNameList,outNameList) + deallocate(inNameList,outNameList) _RETURN(ESMF_SUCCESS) end subroutine CopyState @@ -475,38 +544,69 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) integer, optional, intent(out) :: rc integer :: status - real, pointer :: Exptr2(:,:) => null() + real, pointer :: Exptr2(:,:), Exptr1(:) integer :: itemcount character(len=ESMF_MAXSTR), allocatable :: outNameList(:) - type(ESMF_Field) :: expf,farray(6) + type(ESMF_Field) :: expf,farray(7) type(ESMF_State) :: pstate character(len=:), pointer :: fexpr - integer :: i1,in,j1,jn,ldims(3),i,j + integer :: i1,in,j1,jn,ldims(3),i,j,seed_size,mypet + integer, allocatable :: seeds(:) + type(ESMF_VM) :: vm - call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) - call MAPL_Grid_Interior(grid,i1,in,j1,jn) + if (.not. synth%on_tiles) then + call MAPL_GridGet(grid,localcellcountperdim=ldims,_RC) + call MAPL_Grid_Interior(grid,i1,in,j1,jn) + end if call ESMF_StateGet(outState,itemcount=itemCount,_RC) allocate(outNameList(itemCount),stat=status) _VERIFY(status) call ESMF_StateGet(outState,itemNameList=outNameList,_RC) - call MAPL_GetPointer(inState,exPtr2,'time',_RC) - exPtr2=synth%tFunc%evaluate_time(Time,_RC) + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'time',_RC) + exPtr1=synth%tFunc%evaluate_time(Time,_RC) + else + call MAPL_GetPointer(inState,exPtr2,'time',_RC) + exPtr2=synth%tFunc%evaluate_time(Time,_RC) + end if - call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) - do j = 1,ldims(2) - do i=1,ldims(1) - exPtr2(i,j)=i1+i-1 + if (.not. synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr2,'i_index',_RC) + do j = 1,ldims(2) + do i=1,ldims(1) + exPtr2(i,j)=i1+i-1 + enddo enddo - enddo - call MAPL_GetPointer(inState,exPtr2,'j_index',_RC) - do i = 1,ldims(1) - do j=1,ldims(2) - exPtr2(i,j)=j1+j-1 + call MAPL_GetPointer(inState,exPtr2,'j_index',_RC) + do i = 1,ldims(1) + do j=1,ldims(2) + exPtr2(i,j)=j1+j-1 + enddo enddo - enddo - call MAPL_GetPointer(inState,exPtr2,'doy',_RC) - exPtr2 = compute_doy(time,_RC) + end if + + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'doy',_RC) + exPtr1 = compute_doy(time,_RC) + else + call MAPL_GetPointer(inState,exPtr2,'doy',_RC) + exPtr2 = compute_doy(time,_RC) + end if + + call random_seed(size=seed_size) + allocate(seeds(seed_size)) + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,localPet=mypet,_RC) + seeds = mypet + call random_seed(put=seeds) + if (synth%on_tiles) then + call MAPL_GetPointer(inState,exPtr1,'rand',_RC) + call random_number(exPtr1) + else + call MAPL_GetPointer(inState,exPtr2,'rand',_RC) + call random_number(exPtr2) + end if call ESMF_StateGet(inState,'time',farray(1),_RC) call ESMF_StateGet(inState,'lons',farray(2),_RC) @@ -514,6 +614,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) call ESMF_StateGet(inState,'i_index',farray(4),_RC) call ESMF_StateGet(inState,'j_index',farray(5),_RC) call ESMF_StateGet(inState,'doy',farray(6),_RC) + call ESMF_StateGet(inState,'rand',farray(7),_RC) pstate = ESMF_StateCreate(_RC) call ESMF_StateAdd(pstate,farray,_RC) @@ -539,12 +640,14 @@ subroutine CompareState(State1,State2,tol,rc) real, pointer :: ptr3_2(:,:,:) real, pointer :: ptr2_1(:,:) real, pointer :: ptr2_2(:,:) + real, pointer :: ptr1_1(:) + real, pointer :: ptr1_2(:) integer :: itemcount,rank1,rank2 character(len=ESMF_MAXSTR), allocatable :: NameList(:) logical, allocatable :: foundDiff(:) type(ESMF_Field) :: Field1,Field2 logical :: all_undef1, all_undef2 - + call ESMF_StateGet(State1,itemcount=itemCount,_RC) allocate(NameList(itemCount),stat=status) _VERIFY(status) @@ -556,14 +659,20 @@ subroutine CompareState(State1,State2,tol,rc) call ESMF_StateGet(State2,trim(nameList(i)),field2,_RC) call ESMF_FieldGet(field1,rank=rank1,_RC) call ESMF_FieldGet(field2,rank=rank2,_RC) - all_undef1 = is_field_undef(field1,_RC) - all_undef2 = is_field_undef(field2,_RC) + all_undef1 = FieldIsConstant(field1,MAPL_UNDEF,_RC) + all_undef2 = FieldIsConstant(field2,MAPL_UNDEF,_RC) if (all_undef1 .or. all_undef2) then exit end if _ASSERT(rank1==rank2,'needs informative message') foundDiff(i)=.false. - if (rank1==2) then + if (rank1==1) then + call MAPL_GetPointer(state1,ptr1_1,trim(nameList(i)),_RC) + call MAPL_GetPointer(state2,ptr1_2,trim(nameList(i)),_RC) + if (any((ptr1_1-ptr1_2) > tol)) then + foundDiff(i) = .true. + end if + else if (rank1==2) then call MAPL_GetPointer(state1,ptr2_1,trim(nameList(i)),_RC) call MAPL_GetPointer(state2,ptr2_2,trim(nameList(i)),_RC) if (any((ptr2_1-ptr2_2) > tol)) then @@ -576,11 +685,11 @@ subroutine CompareState(State1,State2,tol,rc) foundDiff(i) = .true. end if end if - if (foundDiff(i)) then + if (foundDiff(i)) then _FAIL('found difference when compare state') end if enddo - + _RETURN(ESMF_SUCCESS) end subroutine CompareState @@ -588,9 +697,9 @@ end subroutine CompareState subroutine ForceAllocation(state,rc) type(ESMF_State), intent(inout) :: state integer, optional, intent(out) :: rc - + integer :: status - + real, pointer :: ptr3d(:,:,:) real, pointer :: ptr2d(:,:) integer :: ii diff --git a/Tests/VarspecDescription.F90 b/Tests/VarspecDescription.F90 index 7f08561bd358..499a81d5a9e8 100644 --- a/Tests/VarspecDescription.F90 +++ b/Tests/VarspecDescription.F90 @@ -57,6 +57,8 @@ function new_VarspecDescriptionFromConfig(cf,nwords,rc) result(VarspecDescr) VarspecDescr%dims = MAPL_DimsHorzOnly else if (trim(tmpstring) == 'xyz') then VarspecDescr%dims = MAPL_DimsHorzVert + else if (trim(tmpstring) == 'tileonly') then + VarspecDescr%dims = MAPL_DimsTileOnly end if tmpstring = svec%at(5) if (trim(tmpstring) == 'none') then diff --git a/Tests/pfio_MAPL_demo.F90 b/Tests/pfio_MAPL_demo.F90 index a601e7ee8f58..b8c84f4534f9 100755 --- a/Tests/pfio_MAPL_demo.F90 +++ b/Tests/pfio_MAPL_demo.F90 @@ -10,7 +10,7 @@ ! !#### Usage: ! -! If we reserve 2 haswell nodes (28 cores in each), want to run the model on 28 cores +! If we reserve 2 haswell nodes (28 cores in each), want to run the model on 28 cores ! and use 1 MultiGroup with 5 backend processes, then the execution command is: !``` ! mpiexec -np 56 pfio_MAPL_demo.x --npes_model 28 --oserver_type multigroup --nodes_output_server 1 --npes_backend_pernode 5 @@ -38,7 +38,7 @@ program main integer, parameter :: num_dims = 2 ! number of dimension to decompose ! PFIO specific variables - type(MAPL_FlapCLI) :: cli + type(MAPL_FargparseCLI) :: cli type(MAPL_CapOptions) :: cap_options type(ServerManager) :: ioserver_manager type(SplitCommunicator) :: split_comm @@ -85,8 +85,7 @@ program main !------------------------------------------------------------------------------ ! Read and parse the command line, and set parameters - cli = MAPL_FlapCLI(description = 'GEOS AGCM', & - authors = 'GMAO') + cli = MAPL_FargparseCLI() cap_options = MAPL_CapOptions(cli) ! Initialize MPI if MPI_Init has not been called @@ -123,22 +122,22 @@ program main ! ---> Perform domain decomposition for the model !------------------------------------------------ call perform_domain_deposition() - + ! Allocate model variables !------------------------- ALLOCATE(local_tracer(i1:i2, j1:j2)) ALLOCATE(local_temp(i1:i2, j1:j2, k1:k2)) - + ! if there are multiple oserver, split it into large and small pool call o_clients%split_server_pools() - + call create_file_metada() - + !--------------------------------------------- ! ---> Model time stepping and writing outputs !--------------------------------------------- call run_model() - + deallocate(local_temp) deallocate(local_tracer) deallocate(points_per_procX) @@ -157,11 +156,11 @@ program main call ioserver_manager%finalize() call MPI_finalize(ierror) - + !------------------------------------------------------------------------------ CONTAINS !------------------------------------------------------------------------------ -!> +!> ! `create_member_subcommunicator` -- Create a subcommunicator ! integer function create_member_subcommunicator(comm, n_members, npes_member, rc) result(subcommunicator) @@ -183,7 +182,7 @@ integer function create_member_subcommunicator(comm, n_members, npes_member, rc) end function create_member_subcommunicator !------------------------------------------------------------------------------ -!> +!> ! `initialize_mpi` -- Initialized MPI is MPI_Init has not been called yet. ! subroutine initialize_mpi(comm) @@ -204,7 +203,7 @@ subroutine initialize_mpi(comm) end subroutine initialize_mpi !------------------------------------------------------------------------------ -!> +!> ! `initialize_ioserver` -- Initialize the IO Server using the command line options ! subroutine initialize_ioserver(comm) @@ -224,7 +223,7 @@ subroutine initialize_ioserver(comm) _VERIFY(status) end subroutine initialize_ioserver !------------------------------------------------------------------------------ -!> +!> ! `perform_domain_deposition` -- Perfom the domain decomposition ! subroutine perform_domain_deposition() @@ -267,7 +266,7 @@ subroutine perform_domain_deposition() print '(a7,i5,a5,4i5)', 'pe_id: ', pe_id, '-->', i1, i2, j1, j2 end subroutine perform_domain_deposition !------------------------------------------------------------------------------ -!> +!> ! `create_file_metada` -- Create the file metada using PFIO methods and the file collection identifier ! subroutine create_file_metada() @@ -348,7 +347,7 @@ subroutine create_file_metada() hist_id = o_clients%add_hist_collection(fmd) end subroutine create_file_metada !------------------------------------------------------------------------------ -!> +!> ! `run_model` -- Run the model and write out the data ! subroutine run_model() @@ -415,7 +414,7 @@ subroutine run_model() enddo end subroutine run_model !------------------------------------------------------------------------------ -!> +!> ! `add_fvar` -- PFIO utility routine to create a variable and set attributes ! subroutine add_fvar(cf, vname, vtype, dims, units, long_name ,rc) @@ -449,10 +448,10 @@ subroutine add_fvar(cf, vname, vtype, dims, units, long_name ,rc) _VERIFY(status) end subroutine add_fvar !------------------------------------------------------------------------------ -!> -! `decompose_dim` -- -! For a given number of grid points along a dimension and a number of -! available processors for that diemsion,, !! determine the number of +!> +! `decompose_dim` -- +! For a given number of grid points along a dimension and a number of +! available processors for that diemsion,, !! determine the number of ! grid points assigned to each processor. ! subroutine decompose_dim(dim_world, dim_array, num_procs ) @@ -472,7 +471,7 @@ subroutine decompose_dim(dim_world, dim_array, num_procs ) end subroutine decompose_dim !------------------------------------------------------------------------------ !> -! `decompose_proc` -- +! `decompose_proc` -- ! Given the total number of available processors and the number of dimensions, ! determine the number of processors along each dimension. ! @@ -491,10 +490,10 @@ subroutine decompose_proc(num_procs, proc_sizes) END DO end subroutine decompose_proc !------------------------------------------------------------------------------ -!> -! `mapping_domain` -- +!> +! `mapping_domain` -- ! Determime the indices of the local domain corners -! with respect to the global domain. +! with respect to the global domain. ! subroutine mapping_domain(map_proc, map_domainX, map_domainY, & points_per_procX, points_per_procY, NX, NY, & @@ -550,7 +549,7 @@ subroutine mapping_domain(map_proc, map_domainX, map_domainY, & enddo end subroutine mapping_domain !------------------------------------------------------------------------------ -!> +!> ! `set_tracer` -- Arbitrary set values for a field ! subroutine set_tracer(var) @@ -566,7 +565,7 @@ subroutine set_tracer(var) end subroutine set_tracer !------------------------------------------------------------------------------ -!> +!> ! `set_temperature` -- Arbitrary set values for the temperature field. ! subroutine set_temperature(var) diff --git a/base/Base.F90 b/base/Base.F90 index 5413bcafbbae..32929296150d 100644 --- a/base/Base.F90 +++ b/base/Base.F90 @@ -51,7 +51,6 @@ module MAPLBase_Mod use MAPL_ServerManager use MAPL_FileMetadataUtilsMod use MAPL_VerticalDataMod - use MAPL_FieldUtilities use MAPL_SphericalGeometry logical, save, private :: mapl_is_initialized = .false. diff --git a/base/Base/Base_Base.F90 b/base/Base/Base_Base.F90 index 4a134533fb40..ebc4b03667fd 100644 --- a/base/Base/Base_Base.F90 +++ b/base/Base/Base_Base.F90 @@ -58,7 +58,6 @@ module MAPL_Base public MAPL_StateAdd public MAPL_FieldBundleAdd public MAPL_FieldBundleGet - public MAPL_FieldDestroy public MAPL_FieldBundleDestroy public MAPL_GetHorzIJIndex public MAPL_GetGlobalHorzIJIndex @@ -642,12 +641,6 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== - module subroutine MAPL_FieldDestroy(Field,RC) - use ESMF, only: ESMF_Field - type(ESMF_Field), intent(INOUT) :: Field - integer, optional, intent(OUT ) :: RC - end subroutine MAPL_FieldDestroy - module subroutine MAPL_FieldBundleDestroy(Bundle,RC) use ESMF, only: ESMF_FieldBundle type(ESMF_FieldBundle), intent(INOUT) :: Bundle diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 4d7631de6c18..627cfa3c2ef4 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -24,6 +24,7 @@ ! !USES: ! use ESMF + use MAPL_Geom use MAPL_Constants use MAPL_RangeMod use MAPL_SphericalGeometry @@ -2644,60 +2645,6 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== - module subroutine MAPL_FieldDestroy(Field,RC) - type(ESMF_Field), intent(INOUT) :: Field - integer, optional, intent(OUT ) :: RC - - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_FieldDestroy" - integer :: STATUS - - real(kind=ESMF_KIND_R4), pointer :: VAR_1D(:), VAR_2D(:,:), VAR_3D(:,:,:) - real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:) - integer :: rank - type(ESMF_TypeKind_Flag) :: tk - - call ESMF_FieldGet(Field,typekind=tk,dimCount=rank,rc=status) - _VERIFY(STATUS) - if (tk == ESMF_TYPEKIND_R4 .and. rank == 1) then - call ESMF_FieldGet(Field,0,VAR_1d,rc=status) - _VERIFY(STATUS) - deallocate(Var_1d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 1) then - call ESMF_FieldGet(Field,0,VR8_1d,rc=status) - _VERIFY(STATUS) - deallocate(VR8_1d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R4 .and. rank == 2) then - call ESMF_FieldGet(Field,0,VAR_2d,rc=status) - _VERIFY(STATUS) - deallocate(Var_2d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 2) then - call ESMF_FieldGet(Field,0,VR8_2d,rc=status) - _VERIFY(STATUS) - deallocate(VR8_2d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R4 .and. rank == 3) then - call ESMF_FieldGet(Field,0,VAR_3D,rc=status) - _VERIFY(STATUS) - deallocate(Var_3d,stat=status) - _VERIFY(STATUS) - else if (tk == ESMF_TYPEKIND_R8 .and. rank == 3) then - call ESMF_FieldGet(Field,0,VR8_3D,rc=status) - _VERIFY(STATUS) - deallocate(VR8_3d,stat=status) - _VERIFY(STATUS) - else - _FAIL( 'unsupported typekind+rank') - end if - call ESMF_FieldDestroy(Field,rc=status) - _VERIFY(STATUS) - - _RETURN(ESMF_SUCCESS) - - end subroutine MAPL_FieldDestroy - module subroutine MAPL_FieldBundleDestroy(Bundle,RC) type(ESMF_FieldBundle), intent(INOUT) :: Bundle integer, optional, intent(OUT ) :: RC diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 8fa9fdb35e76..abfccdcf963f 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -52,7 +52,6 @@ set (srcs Base/Base_Base.F90 Base/Base_Base_implementation.F90 TimeStringConversion.F90 MAPL_ISO8601_DateTime_ESMF.F90 - FieldUtilities.F90 MAPL_Resource.F90 MAPL_XYGridFactory.F90 MAPL_NetCDF.F90 @@ -67,7 +66,7 @@ endif() esma_add_library( ${this} SRCS ${srcs} - DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger + DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 MAPL.geom 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 TYPE ${MAPL_LIBRARY_TYPE}) diff --git a/base/FieldUtilities.F90 b/base/FieldUtilities.F90 deleted file mode 100644 index 6a83c6e6dd8a..000000000000 --- a/base/FieldUtilities.F90 +++ /dev/null @@ -1,53 +0,0 @@ -#include "MAPL_Generic.h" - -module MAPL_FieldUtilities -use ESMF -use MAPL_BaseMod, only: MAPL_Undef -use MAPL_ErrorHandlingMod - -implicit none -private - -public is_field_undef - -contains - -function is_field_undef(field,rc) result(field_is_undef) - logical :: field_is_undef - type(ESMF_Field), intent(in) :: field - integer, optional, intent(out) :: rc - - integer :: status - - real(ESMF_KIND_R4), pointer :: ptr_1d_r4(:), ptr_2d_r4(:,:), ptr_3d_r4(:,:,:), ptr_4d_r4(:,:,:,:) - - integer :: rank - type(ESMF_TypeKind_Flag) :: typekind - - call ESMF_FieldGet(field,rank=rank,typekind=typekind,_RC) - - if (typekind == ESMF_TYPEKIND_R4) then - select case(rank) - case(1) - call ESMF_FieldGet(field,0,farrayPtr=ptr_1d_r4,_RC) - field_is_undef = all(ptr_1d_r4 == MAPL_UNDEF) - case(2) - call ESMF_FieldGet(field,0,farrayPtr=ptr_2d_r4,_RC) - field_is_undef = all(ptr_2d_r4 == MAPL_UNDEF) - case(3) - call ESMF_FieldGet(field,0,farrayPtr=ptr_3d_r4,_RC) - field_is_undef = all(ptr_3d_r4 == MAPL_UNDEF) - case(4) - call ESMF_FieldGet(field,0,farrayPtr=ptr_4d_r4,_RC) - field_is_undef = all(ptr_4d_r4 == MAPL_UNDEF) - end select - else - _FAIL("MAPL_UNDEF is single precision so you can not check if it is all undef for an R8") - end if - - _RETURN(_SUCCESS) - -end function - -end module - diff --git a/base/MAPL_GridManager.F90 b/base/MAPL_GridManager.F90 index e3b0ac058717..ddee627d4297 100644 --- a/base/MAPL_GridManager.F90 +++ b/base/MAPL_GridManager.F90 @@ -479,7 +479,8 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, logical :: hasLongitude = .FALSE. logical :: hasLat = .FALSE. logical :: hasLatitude = .FALSE. - + logical :: splitByface = .FALSE. + _UNUSED_DUMMY(unused) call ESMF_VMGetCurrent(vm, rc=status) @@ -491,6 +492,10 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, _VERIFY(status) file_metadata = file_formatter%read(rc=status) _VERIFY(status) + call file_formatter%close(rc=status) + _VERIFY(status) + + splitByface = file_metadata%has_attribute("Cubed_Sphere_Face_Index") im = 0 hasXdim = file_metadata%has_dimension('Xdim') @@ -526,7 +531,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, if (status == _SUCCESS) then jm = file_metadata%get_dimension('Ydim',rc=status) _VERIFY(status) - if (jm == 6*im) then + if (jm == 6*im .or. splitByface) then allocate(factory, source=this%make_clone('Cubed-Sphere')) else nf = file_metadata%get_dimension('nf',rc=status) @@ -549,7 +554,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, end if end if - if (jm == 6*im) then ! old-format cubed-sphere + if (jm == 6*im .or. splitByface) then ! old-format cubed-sphere allocate(factory, source=this%make_clone('Cubed-Sphere')) !!$ elseif (...) then ! something that is true for tripolar? !!$ factory = this%make_clone('tripolar') @@ -561,7 +566,6 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, call factory%initialize(file_metadata, force_file_coordinates=force_file_coordinates, rc=status) _VERIFY(status) - call file_formatter%close(rc=status) _RETURN(_SUCCESS) diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index d714397803f5..72f62579a996 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -1,5 +1,4 @@ #include "MAPL_Generic.h" -! ! Part of this code is based on a fortran parser by Roland Schmehl: ! !------- -------- --------- --------- --------- --------- --------- --------- ------- @@ -53,6 +52,7 @@ MODULE MAPL_NewArthParserMod use ESMF use MAPL_BaseMod + use MAPL_Geom use MAPL_CommsMod use MAPL_ExceptionHandling use gFTL_StringVector @@ -117,18 +117,11 @@ MODULE MAPL_NewArthParserMod INTEGER :: ByteCodeSize REAL, DIMENSION(:), POINTER :: Immed => NULL() INTEGER :: ImmedSize - TYPE(Ptrs_Type), DIMENSION(:), POINTER :: Stack => NULL() + type(ESMF_Field), allocatable :: stack(:) INTEGER :: StackSize, & StackPtr END TYPE tComp - type Ptrs_Type - integer:: rank - integer, dimension(ESMF_MAXDIM):: lb,ub - real, pointer:: Q2D(:,: ) => null() - real, pointer:: Q3D(:,:,:) => null() - end type Ptrs_Type - CONTAINS subroutine bytecode_dealloc(comp,rc) @@ -136,13 +129,12 @@ subroutine bytecode_dealloc(comp,rc) integer, optional, intent(out ) :: rc integer :: i - character(len=ESMF_MAXSTR), parameter :: Iam = "bytecode_dealloc" + integer :: status do i=1,comp%StackSize - if (associated(comp%stack(i)%Q2D)) deallocate(comp%Stack(i)%Q2D) - if (associated(comp%stack(i)%Q3D)) deallocate(comp%Stack(i)%Q3D) + call MAPL_FieldDestroy(comp%stack(i),_RC) end do - deallocate(comp%Stack) + deallocate(comp%stack) deallocate(comp%ByteCode) deallocate(comp%Immed) _RETURN(ESMF_SUCCESS) @@ -164,37 +156,28 @@ subroutine MAPL_StateEval(state,expression,field,rc) type(tComp) :: pcode logical, allocatable :: needed(:) logical :: isConformal - character(len=ESMF_MAXSTR), parameter :: Iam="MAPL_StateEval" integer :: status - call ESMF_StateGet(state,ITEMCOUNT=varCount,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,ITEMCOUNT=varCount,_RC) allocate(fieldnames(varCount),needed(varCount)) - call ESMF_StateGet(state,itemnamelist=fieldNames,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemnamelist=fieldNames,_RC) ! confirm that each needed field is conformal - call CheckSyntax(expression,fieldNames,needed,rc=status) - _VERIFY(STATUS) + call CheckSyntax(expression,fieldNames,needed,_RC) do i=1,varCount if (needed(i)) then - call ESMF_StateGet(state,fieldNames(i),field=state_field,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,fieldNames(i),field=state_field,_RC) - isConformal = CheckIfConformal(field,state_field,rc=status) - _VERIFY(STATUS) + isConformal = FieldsAreBroadcastConformable(state_field,field,_RC) if (.not.isConformal) then _FAIL('needs informative message') end if end if end do - call parsef (pcode, expression, fieldNames, field, rc=status) - _VERIFY(STATUS) - call evalf(pcode,state,fieldNames,field,rc=status) - _VERIFY(STATUS) - call bytecode_dealloc(pcode,rc=status) - _VERIFY(STATUS) + call parsef (pcode, expression, fieldNames, field, _RC) + call evalf(pcode,state,fieldNames,field,_RC) + call bytecode_dealloc(pcode,_RC) deallocate(fieldNames,needed) @@ -213,16 +196,13 @@ SUBROUTINE parsef (Comp, FuncStr, Var, field, rc) INTEGER, OPTIONAL , INTENT(out ) :: rc CHARACTER(len=LEN(FuncStr)) :: Func - character(len=ESMF_MAXSTR), parameter :: Iam="parsef" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- - CALL CheckSyntax (FuncStr,Var,rc=status) - _VERIFY(STATUS) + CALL CheckSyntax (FuncStr,Var,_RC) Func = FuncStr ! Local copy of function string CALL Replace ('**','^ ',Func) ! Exponent into 1-Char. format CALL RemoveSpaces (Func) ! Condense function string - CALL Compile (comp,Func,Var,field,rc=status) ! Compile into bytecode - _VERIFY(STATUS) + CALL Compile (comp,Func,Var,field,_RC) ! Compile into bytecode _RETURN(ESMF_SUCCESS) END SUBROUTINE parsef ! @@ -241,7 +221,6 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) SP ! Stack pointer INTEGER :: CurrByte,ValNumber TYPE(ESMF_Field) :: state_field - character(len=ESMF_MAXSTR), parameter :: Iam="evalf" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- DP = 1 @@ -250,500 +229,98 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) CurrByte = Comp%ByteCode(IP) if (CurrByte == cImmed) then SP=SP+1 - call CopyScalarToField(Comp%Stack(SP),Comp%Immed(DP),rc=status) - _VERIFY(STATUS) + call FieldSet(comp%stack(sp),comp%immed(dp),_RC) DP=DP+1 end if if (CurrByte == cNeg) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call FieldNegate(comp%stack(sp),_RC) end if if (CurrByte >= cAdd .and. CurrByte <= cPow) then - call ArthFieldToField(Comp%Stack(SP),Comp%Stack(SP-1),CurrByte,rc=status) - _VERIFY(STATUS) + call field_binary(Comp%stack(SP),Comp%stack(SP-1),CurrByte,_RC) SP=SP-1 end if if (CurrByte >= cAbs .and. CurrByte <= cHeav) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call field_unary(comp%stack(sp),currByte,_RC) end if if (CurrByte > cHeav) then SP=SP+1 ValNumber = CurrByte-VarBegin+1 - call ESMF_StateGet(state,FieldNames(ValNumber),state_field,rc=status) - _VERIFY(STATUS) - call CopyFieldToPtr(state_field,Comp%Stack(SP),rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,FieldNames(ValNumber),state_field,_RC) + call FieldCopyBroadcast(state_field,comp%stack(sp),_RC) end if END DO - call CopyPtrToField(Comp%Stack(1),ResField,rc=status) - _VERIFY(STATUS) + call FieldCopyBroadcast(comp%stack(1),ResField,_RC) _RETURN(ESMF_SUCCESS) END SUBROUTINE evalf - FUNCTION CheckIfConformal(field_1,field_2,rc) result(res) - TYPE(ESMF_Field), intent(inout) :: field_1 - TYPE(ESMF_Field), intent(inout) :: field_2 - integer, optional, intent(out ) :: rc - - logical :: res - - character(len=ESMF_MAXSTR), parameter :: Iam ="CheckIfConformal" - integer :: status - type(ESMF_Array) :: array_1,array_2 - type (ESMF_LocalArray), target :: larrayList(1) - type(ESMF_LocalArray), pointer :: larray_1,larray_2 - integer :: rank_1, rank_2 - integer :: lbnds_1(ESMF_MAXDIM), ubnds_1(ESMF_MAXDIM) - integer :: lbnds_2(ESMF_MAXDIM), ubnds_2(ESMF_MAXDIM) - integer :: i - - call ESMF_FieldGet(field_1,array=array_1,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_1, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_1 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_1,rank=rank_1,totalLBound=lbnds_1,totalUBound=ubnds_1,rc=status) - _VERIFY(STATUS) - - call ESMF_FieldGet(field_2,array=array_2,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_2, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_2 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_2,rank=rank_2,totalLBound=lbnds_2,totalUBound=ubnds_2,rc=status) - _VERIFY(STATUS) - - if (rank_1 == 2 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 3) then - do i=1,3 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 2 .and. rank_2 == 3) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - - _RETURN(ESMF_SUCCESS) + subroutine field_binary(field1,field2,arthcode,rc) + type(ESMF_Field), intent(inout) :: field1 + type(ESMF_Field), intent(inout) :: field2 + integer, intent(in) :: arthcode + integer, optional, intent(out) :: rc - END FUNCTION CheckIfConformal - - SUBROUTINE CopyFieldtoPtr(field,ptrs,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" integer :: status - integer :: i - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - ptrs%Q3D=var3d - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - ptrs%Q2D=var2d - else if (rank == 2 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - do i=ptrs%lb(3),ptrs%ub(3) - ptrs%Q3D(:,:,i)=var2d - end do - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyFieldToPtr - - SUBROUTINE CopyPtrtoField(ptrs,field,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" - integer :: status - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - var3d=ptrs%Q3D - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - var2d=ptrs%Q2D - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyPtrToField - - - SUBROUTINE ArthFieldToField(ptrs_1,ptrs_2,arthcode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(Ptrs_Type), intent(inout) :: ptrs_1 - TYPE(Ptrs_Type), intent(inout) :: ptrs_2 - integer, intent(in ) :: arthcode - integer, optional, intent(out ) :: rc - Character(len=ESMF_MAXSTR), parameter :: Iam="ArthFieldToField" - - if (ptrs_1%rank == 3 .and. ptrs_2%rank ==3) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D + ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D - ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D * ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D / ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D ** ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs_1%rank == 2 .and. ptrs_2%rank ==2) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D + ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D - ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D * ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D / ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D ** ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - end select -! maybe put in 2d + 3d, not needed for now - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE ArthFieldToField - - SUBROUTINE UnaryFuncField(ptrs,funcCode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(ptrs_type), intent(inout) :: ptrs + select case(arthcode) + case(cAdd) + call FieldAdd(field2,field2,field1,_RC) + case(cSub) + call FieldSubtract(field2,field2,field1,_RC) + case(cMul) + call FieldMultiply(field2,field2,field1,_RC) + case(cDiv) + call FieldDivide(field2,field2,field1,_RC) + case(cPow) + call FieldPower(field2,field2,field1,_RC) + end select + _RETURN(_SUCCESS) + end subroutine field_binary + + subroutine field_unary(field,funcCode,rc) + type(ESMF_Field), intent(inout) :: field integer, intent(in ) :: funcCode integer, optional, intent(out ) :: rc - character(len=ESMF_MAXSTR), parameter :: Iam="UnaryFuncField" - - if (ptrs%rank == 3) then - select case(funcCode) - case(cNeg) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = -ptrs%Q3D - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = abs(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = exp(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log10(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sqrt(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sinh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cosh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tanh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = asin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = acos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = atan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = Heav3D(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs%rank == 2) then - select case(funcCode) - case(cNeg) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = -ptrs%Q2D - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = abs(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = exp(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log10(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sqrt(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sinh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cosh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tanh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = asin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = acos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = atan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = Heav2D(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - end select - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE UnaryFuncField - - SUBROUTINE CopyScalarToField(ptrs,rn,rc) - ! copy a scalar to ESMF field - TYPE(Ptrs_Type), intent(inout) :: ptrs - real, intent(in ) :: rn - integer, optional, intent(out ) :: rc - - character(len=ESMF_MAXSTR), parameter :: Iam="CopyScalarToField" + integer :: status - if (ptrs%rank == 2) then - ptrs%Q2D=rn - else if (ptrs%rank == 3) then - ptrs%Q3D=rn - end if - _RETURN(ESMF_SUCCESS) + select case(funcCode) + case(cNeg) + call FieldNegate(field,_RC) + case(cAbs) + call FieldAbs(field,field,_RC) + case(cExp) + call FieldExp(field,field,_RC) + case(cLog10) + call FieldLog10(field,field,_RC) + case(cLog) + call FieldLog(field,field,_RC) + case(cSqrt) + call FieldSqrt(field,field,_RC) + case(cSinh) + call FieldSinh(field,field,_RC) + case(cCosh) + call FieldCosh(field,field,_RC) + case(cTanh) + call FieldTanh(field,field,_RC) + case(cSin) + call FieldSin(field,field,_RC) + case(cCos) + call FieldCos(field,field,_RC) + case(cTan) + call FieldTan(field,field,_RC) + case(cAsin) + call FieldAsin(field,field,_RC) + case(cAcos) + call FieldAcos(field,field,_RC) + case(cAtan) + call FieldAtan(field,field,_RC) + case(cHeav) + _FAIL("heaviside needs implementation") + end select + + _RETURN(_SUCCESS) + end subroutine field_unary - END SUBROUTINE CopyScalarToField - ! function parser_variables_in_expression (FuncStr,rc) result(variables_in_expression) !----- -------- --------- --------- --------- --------- --------- --------- ------- ! Check syntax of function string, returns 0 if syntax is ok @@ -761,7 +338,6 @@ function parser_variables_in_expression (FuncStr,rc) result(variables_in_express LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -882,7 +458,6 @@ SUBROUTINE CheckSyntax (FuncStr,Var,needed,ExtVar,rc) LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -1188,18 +763,11 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) TYPE(ESMF_Field) , INTENT(inout) :: field ! resultant field, use to get its rank, etc . . . INTEGER , INTENT(out ) :: rc INTEGER :: istat, i - TYPE(ESMF_Array) :: Array - type (ESMF_LocalArray), target :: larrayList(1) - TYPE(ESMF_LocalArray) ,pointer :: lArray - INTEGER :: ResRank - INTEGER :: lb(ESMF_MAXDIM) - INTEGER :: ub(ESMF_MAXDIM) - character(len=ESMF_MAXSTR), parameter :: Iam = "Compile" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- IF (ASSOCIATED(Comp%ByteCode)) DEALLOCATE ( Comp%ByteCode, & Comp%Immed, & - Comp%Stack ) + Comp%stack ) Comp%ByteCodeSize = 0 Comp%ImmedSize = 0 Comp%StackSize = 0 @@ -1207,25 +775,12 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) CALL CompileSubstr (Comp,F,1,LEN_TRIM(F),Var) ! Compile string to determine size ALLOCATE ( Comp%ByteCode(Comp%ByteCodeSize), & Comp%Immed(Comp%ImmedSize), & - Comp%Stack(Comp%StackSize), & + Comp%stack(comp%stackSize), & STAT = istat ) - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,localarrayList=larrayList,rc=status) - _VERIFY(STATUS) - lArray => lArrayList(1) - call ESMF_LocalArrayGet(larray,rank=ResRank,totallbound=lb,totalubound=ub,rc=status) - _VERIFY(STATUS) DO i=1,Comp%StackSize - Comp%Stack(i)%rank = ResRank - Comp%Stack(i)%lb = lb - Comp%Stack(i)%ub = ub - IF (ResRank == 2) then - allocate(Comp%Stack(i)%Q2D(lb(1):ub(1),lb(2):ub(2)) ) - ELSE IF (ResRank == 3) then - allocate(Comp%Stack(i)%Q3D(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) ) - END IF + call FieldClone(field,comp%stack(i),_RC) + call ESMF_AttributeSet(field,name="missing_value",value=MAPL_UNDEF,_RC) END DO Comp%ByteCodeSize = 0 diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 873ebf6ebf34..acae844fe9ce 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -40,7 +40,6 @@ module NCIOMod public MAPL_VarRead public MAPL_VarWrite public get_fname_by_face - public MAPL_TileMaskGet public MAPL_NCIOGetFileType public MAPL_VarReadNCPar public MAPL_VarWriteNCPar diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake new file mode 100644 index 000000000000..161654428d88 --- /dev/null +++ b/cmake/FindESMF.cmake @@ -0,0 +1,138 @@ +# - Try to find ESMF +# +# Uses ESMFMKFILE to find the filepath of esmf.mk. If this is NOT set, then this +# module will attempt to find esmf.mk. If ESMFMKFILE exists, then +# ESMF_FOUND=TRUE and all ESMF makefile variables will be set in the global +# scope. Optionally, set ESMF_MKGLOBALS to a string list to filter makefile +# variables. For example, to globally scope only ESMF_LIBSDIR and ESMF_APPSDIR +# variables, use this CMake command in CMakeLists.txt: +# +# set(ESMF_MKGLOBALS "LIBSDIR" "APPSDIR") + +# Set ESMFMKFILE as defined by system env variable. If it's not explicitly set +# try to find esmf.mk file in default locations (ESMF_ROOT, CMAKE_PREFIX_PATH, +# etc) +if(NOT DEFINED ESMFMKFILE) + if(NOT DEFINED ENV{ESMFMKFILE}) + find_path(ESMFMKFILE_PATH esmf.mk PATH_SUFFIXES lib lib64) + if(ESMFMKFILE_PATH) + set(ESMFMKFILE ${ESMFMKFILE_PATH}/esmf.mk) + message(STATUS "Found esmf.mk file ${ESMFMKFILE}") + endif() + else() + set(ESMFMKFILE $ENV{ESMFMKFILE}) + endif() +endif() + +# Only parse the mk file if it is found +if(EXISTS ${ESMFMKFILE}) + set(ESMFMKFILE ${ESMFMKFILE} CACHE FILEPATH "Path to esmf.mk file") + set(ESMF_FOUND TRUE CACHE BOOL "esmf.mk file found" FORCE) + + # Read the mk file + file(STRINGS "${ESMFMKFILE}" esmfmkfile_contents) + # Parse each line in the mk file + foreach(str ${esmfmkfile_contents}) + # Only consider uncommented lines + string(REGEX MATCH "^[^#]" def ${str}) + # Line is not commented + if(def) + # Extract the variable name + string(REGEX MATCH "^[^=]+" esmf_varname ${str}) + # Extract the variable's value + string(REGEX MATCH "=.+$" esmf_vardef ${str}) + # Only for variables with a defined value + if(esmf_vardef) + # Get rid of the assignment string + string(SUBSTRING ${esmf_vardef} 1 -1 esmf_vardef) + # Remove whitespace + string(STRIP ${esmf_vardef} esmf_vardef) + # A string or single-valued list + if(NOT DEFINED ESMF_MKGLOBALS) + # Set in global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in GUI + mark_as_advanced(esmf_varname) + else() # Need to filter global promotion + foreach(m ${ESMF_MKGLOBALS}) + string(FIND ${esmf_varname} ${m} match) + # Found the string + if(NOT ${match} EQUAL -1) + # Promote to global scope + set(${esmf_varname} ${esmf_vardef}) + # Don't display by default in the GUI + mark_as_advanced(esmf_varname) + # No need to search for the current string filter + break() + endif() + endforeach() + endif() + endif() + endif() + endforeach() + + # Construct ESMF_VERSION from ESMF_VERSION_STRING_GIT + # ESMF_VERSION_MAJOR and ESMF_VERSION_MINOR are defined in ESMFMKFILE + set(ESMF_VERSION 0) + set(ESMF_VERSION_PATCH ${ESMF_VERSION_REVISION}) + set(ESMF_BETA_RELEASE FALSE) + if(ESMF_VERSION_BETASNAPSHOT MATCHES "^('T')$") + set(ESMF_BETA_RELEASE TRUE) + if(ESMF_VERSION_STRING_GIT MATCHES "^ESMF.*beta_snapshot") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + elseif(ESMF_VERSION_STRING_GIT MATCHES "^v.\..\..b") + set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) + else() + set(ESMF_BETA_SNAPSHOT 0) + endif() + message(STATUS "Detected ESMF Beta snapshot: ${ESMF_BETA_SNAPSHOT}") + endif() + set(ESMF_VERSION "${ESMF_VERSION_MAJOR}.${ESMF_VERSION_MINOR}.${ESMF_VERSION_PATCH}") + + # Find the ESMF library + if(USE_ESMF_STATIC_LIBS) + find_library(ESMF_LIBRARY_LOCATION NAMES libesmf.a PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "Static ESMF library (libesmf.a) not found in \ + ${ESMF_LIBSDIR}. Try setting USE_ESMF_STATIC_LIBS=OFF") + endif() + add_library(ESMF STATIC IMPORTED) + else() + find_library(ESMF_LIBRARY_LOCATION NAMES esmf PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) + if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") + message(WARNING "ESMF library not found in ${ESMF_LIBSDIR}.") + endif() + add_library(ESMF UNKNOWN IMPORTED) + endif() + + # Add ESMF include directories + set(ESMF_INCLUDE_DIRECTORIES "") + separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) + foreach(_ITEM ${_ESMF_F90COMPILEPATHS}) + string(REGEX REPLACE "^-I" "" _ITEM "${_ITEM}") + list(APPEND ESMF_INCLUDE_DIRECTORIES ${_ITEM}) + endforeach() + + # Add ESMF link libraries + string(STRIP "${ESMF_F90LINKRPATHS} ${ESMF_F90ESMFLINKRPATHS} ${ESMF_F90ESMFLINKPATHS} ${ESMF_F90LINKPATHS} ${ESMF_F90LINKLIBS} ${ESMF_F90LINKOPTS}" ESMF_INTERFACE_LINK_LIBRARIES) + + # Finalize find_package + include(FindPackageHandleStandardArgs) + + find_package_handle_standard_args( + ${CMAKE_FIND_PACKAGE_NAME} + REQUIRED_VARS ESMF_LIBRARY_LOCATION + ESMF_INTERFACE_LINK_LIBRARIES + ESMF_F90COMPILEPATHS + VERSION_VAR ESMF_VERSION) + + set_target_properties(ESMF PROPERTIES + IMPORTED_LOCATION "${ESMF_LIBRARY_LOCATION}" + INTERFACE_INCLUDE_DIRECTORIES "${ESMF_INCLUDE_DIRECTORIES}" + INTERFACE_LINK_LIBRARIES "${ESMF_INTERFACE_LINK_LIBRARIES}") + +else() + set(ESMF_FOUND FALSE CACHE BOOL "esmf.mk file NOT found" FORCE) + message(WARNING "ESMFMKFILE ${ESMFMKFILE} not found. Try setting ESMFMKFILE \ + to esmf.mk location.") +endif() diff --git a/components.yaml b/components.yaml index 615e0a155a61..6192688644d7 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.9.1 + tag: v4.19.0 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.28.0 + tag: v3.31.0 develop: develop ecbuild: diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index d1aaaacdc82c..ded579e225c1 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -6068,8 +6068,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) character(len=ESMF_MAXSTR) :: FileType integer :: isNC4 logical :: isPresent - class(AbstractGridFactory), pointer :: app_factory - class (AbstractGridFactory), allocatable :: file_factory character(len=ESMF_MAXSTR) :: grid_type logical :: empty @@ -6306,13 +6304,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_AttributeGet(MPL%GRID%ESMFGRID,'GridType',value=grid_type,rc=status) _VERIFY(status) end if - !note this only works for geos cubed-sphere restarts currently because of - !possible insufficent metadata in the other restarts to support the other grid factories - if (trim(grid_type) == 'Cubed-Sphere') then - app_factory => get_factory(MPL%GRID%ESMFGRID) - allocate(file_factory,source=grid_manager%make_factory(trim(fname))) - _ASSERT(file_factory%physical_params_are_equal(app_factory),"Factories not equal") - end if + _ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") call ArrDescrSetNCPar(arrdes,MPL,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) end if PNC4_TILE @@ -6377,6 +6369,35 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) _RETURN(ESMF_SUCCESS) + + contains + function grid_is_consistent(grid_type, fname) result( consistent) + logical :: consistent + character(*), intent(in) :: grid_type + character(*), intent(in) :: fname + !note this only works for geos cubed-sphere restarts currently because of + !possible insufficent metadata in the other restarts to support the other grid factories + class(AbstractGridFactory), pointer :: app_factory + class (AbstractGridFactory), allocatable :: file_factory + character(len=:), allocatable :: fname_by_face + logical :: fexist + + consistent = .True. + if (trim(grid_type) == 'Cubed-Sphere') then + app_factory => get_factory(MPL%GRID%ESMFGRID) + ! at this point, arrdes%read_restart_by_face is not initialized + ! pick the first face + fname_by_face = get_fname_by_face(trim(fname), 1) + inquire(FILE = trim(fname_by_face), EXIST=fexist) + if(fexist) then + allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) + else + allocate(file_factory,source=grid_manager%make_factory(trim(fname))) + endif + consistent = file_factory%physical_params_are_equal(app_factory) + end if + end function + end subroutine MAPL_ESMFStateReadFromFile !============================================================================= diff --git a/geom/CMakeLists.txt b/geom/CMakeLists.txt index 737071fc94ec..ee50231021fb 100644 --- a/geom/CMakeLists.txt +++ b/geom/CMakeLists.txt @@ -11,7 +11,12 @@ esma_set_this (OVERRIDE MAPL.geom) # StateSupplement.F90 # ) set(srcs + geom.F90 FieldBLAS.F90 + FieldPointerUtilities.F90 + FieldUtilities.F90 + FieldUnaryFunctions.F90 + FieldBinaryOperations.F90 ) # Workaround for strict NAG Fortran with ESMF implicit interface for private state. #set_property( SOURCE InnerMetaComponent.F90 OuterMetaComponent.F90 @@ -25,10 +30,10 @@ endif () esma_add_library(${this} SRCS ${srcs} -# DEPENDENCIES MAPL.oomph MAPL.shared MAPL.profiler MAPL.base YAFYAML::yafyaml PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL::gftl-v2 DEPENDENCIES MAPL.shared PFLOGGER::pflogger TYPE ${MAPL_LIBRARY_TYPE} ) + #add_subdirectory(specs) #add_subdirectory(registry) #add_subdirectory(connection_pt) @@ -40,6 +45,6 @@ target_link_libraries (${this} PUBLIC esmf) if (PFUNIT_FOUND) # Turning off until test with GNU can be fixed - #add_subdirectory(tests EXCLUDE_FROM_ALL) + add_subdirectory(tests EXCLUDE_FROM_ALL) endif () diff --git a/geom/FieldBLAS.F90 b/geom/FieldBLAS.F90 index 4d87022773ae..fdc6a8f338b9 100644 --- a/geom/FieldBLAS.F90 +++ b/geom/FieldBLAS.F90 @@ -3,13 +3,13 @@ module mapl3g_FieldBLAS use ESMF use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 implicit none private ! Level 1 BLAS - public :: FieldCOPY public :: FieldSCAL public :: FieldAXPY @@ -40,20 +40,7 @@ module mapl3g_FieldBLAS ! Misc utiliities public :: FieldSpread - public :: FieldClone public :: FieldConvertPrec - public :: FieldGetLocalElementCount - public :: FieldGetLocalSize - public :: FieldGetCptr - public :: FieldsAreConformable - public :: FieldsAreSameTypeKind -!wdb fixme temporary to test out this helper function - public :: assign_fptr - - ! call FieldCOPY(x, y, rc): y = x - interface FieldCOPY - procedure copy - end interface FieldCOPY !wdb fixme This acts on y in-place. Do we need a form that acts more like a function: y = FieldSCAL(a, x)? ! call FieldSCAL(a, x, rc): x = a*x (multiply x in-place) @@ -74,23 +61,6 @@ module mapl3g_FieldBLAS procedure gemv_r8 end interface - interface FieldGetCptr - procedure get_cptr - end interface - - interface FieldsAreConformable - procedure are_conformable_scalar - procedure are_conformable_array - end interface - - interface FieldGetLocalSize - procedure get_local_size - end interface FieldGetLocalSize - - interface FieldGetLocalElementCount - procedure get_local_element_count - end interface FieldGetLocalElementCount - interface FieldConvertPrec module procedure convert_prec end interface FieldConvertPrec @@ -99,21 +69,6 @@ module mapl3g_FieldBLAS module procedure spread_scalar end interface FieldSpread - interface FieldClone - module procedure clone - end interface FieldClone - - interface assign_fptr - module procedure assign_fptr_r4_rank1 - module procedure assign_fptr_r8_rank1 - module procedure assign_fptr_r4_rank2 - module procedure assign_fptr_r8_rank2 - end interface assign_fptr - - interface FieldsAreSameTypeKind - module procedure are_same_type_kind - end interface FieldsAreSameTypeKind - interface verify_typekind module procedure verify_typekind_scalar module procedure verify_typekind_array @@ -121,109 +76,6 @@ module mapl3g_FieldBLAS contains - !wdb fixme Is this a deep copy? - subroutine copy(x, y, rc) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - type(ESMF_TypeKind_Flag) :: tk_x, tk_y - type(c_ptr) :: cptr_x, cptr_y - integer(kind=ESMF_KIND_I8) :: n - integer :: status - logical :: conformable - logical :: x_is_double - logical :: y_is_double - character(len=*), parameter :: UNSUPPORTED_TK = & - 'Unsupported typekind in FieldCOPY() for ' - - conformable = FieldsAreConformable(x, y) - !wdb fixme need to pass RC - _ASSERT(conformable, 'FieldCopy() - fields not conformable.') - call FieldGetCptr(x, cptr_x, _RC) - call ESMF_FieldGet(x, typekind = tk_x, _RC) - - n = FieldGetLocalSize(x, _RC) - - call FieldGetCptr(y, cptr_y, _RC) - call ESMF_FieldGet(y, typekind = tk_y, _RC) - - !wdb fixme convert between precisions ? get rid of extra cases - y_is_double = (tk_y == ESMF_TYPEKIND_R8) - _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') - - x_is_double = (tk_x == ESMF_TYPEKIND_R8) - _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') - - if (y_is_double) then - if (x_is_double) then - call copy_r8_r8(cptr_x, cptr_y, n) - else - call copy_r4_r8(cptr_x, cptr_y, n) - end if - else - if (x_is_double) then - call copy_r8_r4(cptr_x, cptr_y, n) - else - call copy_r4_r4(cptr_x, cptr_y, n) - end if - end if - - _RETURN(_SUCCESS) - end subroutine copy - - subroutine copy_r4_r4(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r4_r4 - - subroutine copy_r4_r8(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r4_r8 - - subroutine copy_r8_r4(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r8_r4 - - subroutine copy_r8_r8(cptr_x, cptr_y, n) - type(c_ptr), intent(in) :: cptr_x, cptr_y - integer(ESMF_KIND_I8), intent(in) :: n - - real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) - real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) - - call c_f_pointer(cptr_x, x_ptr, [n]) - call c_f_pointer(cptr_y, y_ptr, [n]) - - y_ptr=x_ptr - end subroutine copy_r8_r8 - subroutine scale_r4(a, x, rc) real(kind=ESMF_KIND_R4), intent(in) :: a type(ESMF_Field), intent(inout) :: x @@ -435,39 +287,6 @@ function spread_scalar(source, ncopies, rc) result(vector) _RETURN(_SUCCESS) end function spread_scalar - subroutine clone(x, y, rc) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - character(len=*), parameter :: CLONE_TAG = '_clone' - type(ESMF_ArraySpec) :: arrayspec - type(ESMF_Grid) :: grid - type(ESMF_StaggerLoc) :: staggerloc - integer, allocatable :: gridToFieldMap(:) - integer, allocatable :: ungriddedLBound(:) - integer, allocatable :: ungriddedUBound(:) - integer, allocatable :: totalLWidth(:,:) - integer, allocatable :: totalUWidth(:,:) - character(len=:), allocatable :: name - integer :: status - - call ESMF_FieldGet(x, arrayspec=arrayspec, grid=grid, & - staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & - totalLWidth=totalLWidth, totalUWidth=totalUWidth, _RC) - - name = name // CLONE_TAG - - y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & - gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & - ungriddedUBound=ungriddedUBound, name=name, _RC) -! ungriddedUBound=ungriddedUBound, totalLWidth=totalLWidth, & -! totalUWidth=totalUWidth, name=name, _RC) - - _RETURN(_SUCCESS) - end subroutine clone - subroutine get_typekind(x, expected_tks, actual_tk, rc) type(ESMF_Field), intent(inout) :: x type(ESMF_TypeKind_Flag), intent(in) :: expected_tks(:) @@ -531,253 +350,6 @@ end subroutine verify_typekind_array ! _RETURN(_SUCCESS) ! end subroutine verify_typekind_rank1 - subroutine assign_fptr_r4_rank1(x, fptr, rc) - type(ESMF_Field), intent(inout) :: x - real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer(ESMF_KIND_I8), allocatable :: fp_shape(:) - integer(ESMF_KIND_I8) :: local_size - integer :: status - - local_size = FieldGetLocalSize(x, _RC) - fp_shape = [ local_size ] - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r4_rank1 - - subroutine assign_fptr_r8_rank1(x, fptr, rc) - type(ESMF_Field), intent(inout) :: x - real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer(ESMF_KIND_I8), allocatable :: fp_shape(:) - integer(ESMF_KIND_I8) :: local_size - integer :: status - - local_size = FieldGetLocalSize(x, _RC) - fp_shape = [ local_size ] - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r8_rank1 - - subroutine assign_fptr_r4_rank2(x, fp_shape, fptr, rc) - type(ESMF_Field), intent(inout) :: x - integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) - real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:,:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer :: status - - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r4_rank2 - - subroutine assign_fptr_r8_rank2(x, fp_shape, fptr, rc) - type(ESMF_Field), intent(inout) :: x - integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) - real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:,:) - integer, optional, intent(out) :: rc - - ! local declarations - type(c_ptr) :: cptr - integer :: status - - call FieldGetCptr(x, cptr, _RC) - call c_f_pointer(cptr, fptr, fp_shape) - - _RETURN(_SUCCESS) - end subroutine assign_fptr_r8_rank2 - - subroutine get_cptr(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - type(ESMF_TypeKind_Flag) :: tk_x - - call ESMF_FieldGet(x, typekind=tk_x, _RC) - - if (tk_x == ESMF_TYPEKIND_R4) then - call get_cptr_r4(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_R8) then - call get_cptr_r8(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_I4) then - call get_cptr_i4(x, cptr, _RC) - elseif (tk_x == ESMF_TYPEKIND_I8) then - call get_cptr_i8(x, cptr, _RC) - else - _FAIL('Unsupported typekind in FieldGetCptr().') - end if - - _RETURN(_SUCCESS) - end subroutine get_cptr - - subroutine get_cptr_r4(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - real(kind=ESMF_KIND_R4), pointer :: x_1d(:) - real(kind=ESMF_KIND_R4), pointer :: x_2d(:,:) - real(kind=ESMF_KIND_R4), pointer :: x_3d(:,:,:) - real(kind=ESMF_KIND_R4), pointer :: x_4d(:,:,:,:) - real(kind=ESMF_KIND_R4), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_r4 - - subroutine get_cptr_r8(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - real(kind=ESMF_KIND_R8), pointer :: x_1d(:) - real(kind=ESMF_KIND_R8), pointer :: x_2d(:,:) - real(kind=ESMF_KIND_R8), pointer :: x_3d(:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_4d(:,:,:,:) - real(kind=ESMF_KIND_R8), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_r8 - - subroutine get_cptr_i4(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - integer(kind=ESMF_KIND_I4), pointer :: x_1d(:) - integer(kind=ESMF_KIND_I4), pointer :: x_2d(:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_3d(:,:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_4d(:,:,:,:) - integer(kind=ESMF_KIND_I4), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_i4 - - subroutine get_cptr_i8(x, cptr, rc) - type(ESMF_Field), intent(inout) :: x - type(c_ptr), intent(out) :: cptr - integer, optional, intent(out) :: rc - - integer :: status - integer :: rank - integer(kind=ESMF_KIND_I8), pointer :: x_1d(:) - integer(kind=ESMF_KIND_I8), pointer :: x_2d(:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_3d(:,:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_4d(:,:,:,:) - integer(kind=ESMF_KIND_I8), pointer :: x_5d(:,:,:,:,:) - - call ESMF_FieldGet(x, rank=rank, _RC) - - select case (rank) - case (1) - call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) - cptr = c_loc(x_1d) - case (2) - call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) - cptr = c_loc(x_2d) - case (3) - call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) - cptr = c_loc(x_3d) - case (4) - call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) - cptr = c_loc(x_4d) - case (5) - call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) - cptr = c_loc(x_5d) - case default - _FAIL('Unsupported rank in FieldGetCptr().') - end select - - _RETURN(_SUCCESS) - end subroutine get_cptr_i8 - subroutine convert_prec(x, y, rc) type(ESMF_Field), intent(inout) :: x type(ESMF_Field), intent(inout) :: y @@ -851,148 +423,4 @@ subroutine convert_prec_R8_to_R4(original, converted, rc) _RETURN(_SUCCESS) end subroutine convert_prec_R8_to_R4 - logical function are_conformable_scalar(x, y, rc) result(conformable) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - integer :: rank_x, rank_y - integer, dimension(:), allocatable :: count_x, count_y - integer :: status - - conformable = .false. - - call ESMF_FieldGet(x, rank=rank_x, _RC) - call ESMF_FieldGet(y, rank=rank_y, _RC) - - if(rank_x == rank_y) then - count_x = FieldGetLocalElementCount(x, _RC) - count_y = FieldGetLocalElementCount(y, _RC) - conformable = all(count_x == count_y) - end if - - _RETURN(_SUCCESS) - end function are_conformable_scalar - - logical function are_conformable_array(x, y, rc) result(conformable) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y(:) - integer, optional, intent(out) :: rc - - integer :: status - integer :: j - logical :: element_not_conformable - - conformable = .false. - element_not_conformable = .false. - - do j = 1, size(y) - element_not_conformable = .not. FieldsAreConformable(x, y(j), _RC) - if(element_not_conformable) return - end do - - conformable = .true. - - _RETURN(_SUCCESS) - end function are_conformable_array -! logical function are_conformable_array_array(x, y) result(conformable) -! type(ESMF_Field), intent(inout) :: x(:) -! type(ESMF_Field), intent(inout) :: y(:) -! -! integer :: status -! integer :: j -! -! conformable = .false. -! -! if(size(x) == 1) then -! do j = 1, size(y) -! if(.not. FieldsAreConformable(x(1), y(j))) return -! end do -! elseif(size(x) == size(y)) then -! do j = 1, size(y) -! if(.not. FieldsAreConformable(x(j), y(j))) return -! end do -! else -! return -! end if -! -! conformable = .true. -! -! end function are_conformable_array_array -! -! logical function are_conformable_scalar_array(x, y, rc) result(conformable) -! type(ESMF_Field), intent(inout) :: x -! type(ESMF_Field), intent(inout) :: y(:) -! integer, optional, intent(out) :: rc -! -! integer :: status -! integer :: j -! -! do j = 1, size(y) -! conformable = FieldsAreConformable(x, y(j)) -! end do -! -! _RETURN(_SUCCESS) -! end function are_conformable_scalar_array -! -! logical function are_conformable_array_scalar(x, y, rc) result(conformable) -! type(ESMF_Field), intent(inout) :: x(:) -! type(ESMF_Field), intent(inout) :: y -! integer, optional, intent(out) :: rc -! -! integer :: status -! -! conformable = FieldsAreConformable(y, x) -! -! _RETURN(_SUCCESS) -! end function are_conformable_array_scalar - - logical function are_same_type_kind(x, y, rc) result(same_tk) - type(ESMF_Field), intent(inout) :: x - type(ESMF_Field), intent(inout) :: y - integer, optional, intent(out) :: rc - - integer :: status - type(ESMF_TypeKind_Flag) :: tk_x, tk_y - - same_tk = .false. - call ESMF_FieldGet(x, typekind=tk_x, _RC) - call ESMF_FieldGet(y, typekind=tk_y, _RC) - - same_tk = (tk_x == tk_y) - - _RETURN(_SUCCESS) - end function are_same_type_kind - - function get_local_element_count(x, rc) result(element_count) - type(ESMF_Field), intent(inout) :: x - integer, optional, intent(out) :: rc - integer, allocatable :: element_count(:) - - integer :: status - integer :: rank - -! element_count = [integer :: ] ! default - - call ESMF_FieldGet(x, rank=rank, _RC) - allocate(element_count(rank)) - call ESMF_FieldGet(x, localElementCount=element_count, _RC) - - _RETURN(_SUCCESS) - end function get_local_element_count - - function get_local_size(x, rc) result(sz) - integer(kind=ESMF_KIND_I8) :: sz - type(ESMF_Field), intent(inout) :: x - integer, optional, intent(out) :: rc - - integer :: status - integer, allocatable :: element_count(:) - - sz = 0 - element_count = FieldGetLocalElementCount(x, _RC) - sz = int(product(element_count), kind=ESMF_KIND_I8) - - _RETURN(_SUCCESS) - end function get_local_size - end module mapl3g_FieldBLAS diff --git a/geom/FieldBinaryOperations.F90 b/geom/FieldBinaryOperations.F90 new file mode 100644 index 000000000000..3b4bbff8f706 --- /dev/null +++ b/geom/FieldBinaryOperations.F90 @@ -0,0 +1,49 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldBinaryOperations + use ESMF + use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + implicit none + private + + public fieldAdd + public fieldSubtract + public fieldDivide + public fieldMultiply + public fieldPower + + contains + +#define _OP + +#define _FUNC Add +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP - +#define _FUNC Subtract +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP * +#define _FUNC Multiply +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP / +#define _FUNC Divide +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +#define _OP ** +#define _FUNC Power +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + +end module MAPL_FieldBinaryOperations diff --git a/geom/FieldBinaryOperatorTemplate.H b/geom/FieldBinaryOperatorTemplate.H new file mode 100644 index 000000000000..765f28b7263e --- /dev/null +++ b/geom/FieldBinaryOperatorTemplate.H @@ -0,0 +1,70 @@ +#define _NAME field +#include "function_overload.macro" + + subroutine _SUB(field_out,field_a,field_b,rc) + type(ESMF_Field), intent(inout) :: field_out + type(ESMF_Field), intent(inout) :: field_a + type(ESMF_Field), intent(inout) :: field_b + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_a,tk_b,tk_out + logical :: has_undef,conformable + type(ESMF_Field) :: fields(3) + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + real(kind=ESMF_KIND_R4), pointer :: ptr1_r4(:), ptr2_r4(:), ptr_out_r4(:) + real(kind=ESMF_KIND_R8), pointer :: ptr1_r8(:), ptr2_r8(:), ptr_out_r8(:) + + fields(1)=field_a + fields(2)=field_b + fields(3)=field_out + conformable = FieldsAreConformable(field_a,field_out,_RC) + _ASSERT(conformable,"Fields passed binary operator are not conformable") + conformable = FieldsAreConformable(field_b,field_out,_RC) + _ASSERT(conformable,"Fields passed binary operator are not conformable") + + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field_a,typekind=tk_a,_RC) + call ESMF_FieldGet(field_b,typekind=tk_b,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + + _ASSERT(tk_a==tk_out, "For now we will only allow operations on same type fields") + _ASSERT(tk_b==tk_out, "For now we will only allow operations on same type fields") + + if (tk_a ==ESMF_TypeKind_R4) then + call assign_fptr(field_a,ptr1_r4,_RC) + call assign_fptr(field_b,ptr2_r4,_RC) + call assign_fptr(field_out,ptr_out_r4,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where( (ptr1_r4 /= undef_r4(1)) .and. (ptr2_r4 /= undef_r4(2)) ) + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 + elsewhere + ptr_out_r4 = undef_r4(3) + end where + else + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 + end if + else if (tk_A == ESMF_TypeKind_R8) then + call assign_fptr(field_a,ptr1_r8,_RC) + call assign_fptr(field_b,ptr2_r8,_RC) + call assign_fptr(field_out,ptr_out_r8,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where( (ptr1_r8 /= undef_r8(1)) .and. (ptr2_r8 /= undef_r8(2)) ) + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 + else where + ptr_out_r8 = undef_r8(3) + endwhere + else + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 + end if + else + _FAIL("unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine _SUB + +#include "undo_function_overload.macro" +#undef _NAME diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 new file mode 100644 index 000000000000..aa6cdddd3a11 --- /dev/null +++ b/geom/FieldPointerUtilities.F90 @@ -0,0 +1,949 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldPointerUtilities + use ESMF + use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 + implicit none + private + + public :: FieldsHaveUndef + public :: GetFieldsUndef + public :: assign_fptr + public :: FieldGetLocalElementCount + public :: FieldGetLocalSize + public :: FieldGetCptr + public :: FieldClone + public :: FieldsAreConformable + public :: FieldsAreBroadcastConformable + public :: FieldsAreSameTypeKind + public :: FieldCopy + public :: MAPL_FieldDestroy + public :: FieldCopyBroadcast + + interface GetFieldsUndef + module procedure GetFieldsUndef_r4 + module procedure GetFieldsUndef_r8 + end interface + + interface assign_fptr + module procedure assign_fptr_r4_rank1 + module procedure assign_fptr_r8_rank1 + module procedure assign_fptr_r4_rank2 + module procedure assign_fptr_r8_rank2 + end interface assign_fptr + + interface FieldGetCptr + procedure get_cptr + end interface + + interface FieldGetLocalSize + procedure get_local_size + end interface FieldGetLocalSize + + interface FieldGetLocalElementCount + procedure get_local_element_count + end interface FieldGetLocalElementCount + + interface FieldsAreConformable + procedure are_conformable_scalar + procedure are_conformable_array + end interface + + interface FieldsAreBroadCastConformable + procedure are_broadcast_conformable + end interface + + interface FieldClone + module procedure clone + end interface FieldClone + + interface FieldsAreSameTypeKind + module procedure are_same_type_kind + end interface FieldsAreSameTypeKind + + interface verify_typekind + module procedure verify_typekind_scalar + module procedure verify_typekind_array + end interface verify_typekind + + interface FieldCOPY + procedure copy + end interface FieldCOPY + + interface FieldCopyBroadcast + procedure copy_broadcast + end interface FieldCopyBroadcast + + interface MAPL_FieldDestroy + procedure destroy + end interface +contains + + + subroutine assign_fptr_r4_rank1(x, fptr, rc) + type(ESMF_Field), intent(inout) :: x + real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer(ESMF_KIND_I8), allocatable :: fp_shape(:) + integer(ESMF_KIND_I8) :: local_size + integer :: status + + local_size = FieldGetLocalSize(x, _RC) + fp_shape = [ local_size ] + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r4_rank1 + + subroutine assign_fptr_r8_rank1(x, fptr, rc) + type(ESMF_Field), intent(inout) :: x + real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer(ESMF_KIND_I8), allocatable :: fp_shape(:) + integer(ESMF_KIND_I8) :: local_size + integer :: status + + local_size = FieldGetLocalSize(x, _RC) + fp_shape = [ local_size ] + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r8_rank1 + + subroutine assign_fptr_r4_rank2(x, fp_shape, fptr, rc) + type(ESMF_Field), intent(inout) :: x + integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) + real(kind=ESMF_KIND_R4), pointer, intent(out) :: fptr(:,:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer :: status + + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r4_rank2 + + subroutine assign_fptr_r8_rank2(x, fp_shape, fptr, rc) + type(ESMF_Field), intent(inout) :: x + integer(ESMF_KIND_I8), intent(in) :: fp_shape(:) + real(kind=ESMF_KIND_R8), pointer, intent(out) :: fptr(:,:) + integer, optional, intent(out) :: rc + + ! local declarations + type(c_ptr) :: cptr + integer :: status + + call FieldGetCptr(x, cptr, _RC) + call c_f_pointer(cptr, fptr, fp_shape) + + _RETURN(_SUCCESS) + end subroutine assign_fptr_r8_rank2 + + subroutine get_cptr(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_x + + call ESMF_FieldGet(x, typekind=tk_x, _RC) + + if (tk_x == ESMF_TYPEKIND_R4) then + call get_cptr_r4(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_R8) then + call get_cptr_r8(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_I4) then + call get_cptr_i4(x, cptr, _RC) + elseif (tk_x == ESMF_TYPEKIND_I8) then + call get_cptr_i8(x, cptr, _RC) + else + _FAIL('Unsupported typekind in FieldGetCptr().') + end if + + _RETURN(_SUCCESS) + end subroutine get_cptr + + subroutine get_cptr_r4(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + real(kind=ESMF_KIND_R4), pointer :: x_1d(:) + real(kind=ESMF_KIND_R4), pointer :: x_2d(:,:) + real(kind=ESMF_KIND_R4), pointer :: x_3d(:,:,:) + real(kind=ESMF_KIND_R4), pointer :: x_4d(:,:,:,:) + real(kind=ESMF_KIND_R4), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_r4 + + subroutine get_cptr_r8(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + real(kind=ESMF_KIND_R8), pointer :: x_1d(:) + real(kind=ESMF_KIND_R8), pointer :: x_2d(:,:) + real(kind=ESMF_KIND_R8), pointer :: x_3d(:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_4d(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_r8 + + subroutine get_cptr_i4(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + integer(kind=ESMF_KIND_I4), pointer :: x_1d(:) + integer(kind=ESMF_KIND_I4), pointer :: x_2d(:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_3d(:,:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_4d(:,:,:,:) + integer(kind=ESMF_KIND_I4), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_i4 + + subroutine get_cptr_i8(x, cptr, rc) + type(ESMF_Field), intent(inout) :: x + type(c_ptr), intent(out) :: cptr + integer, optional, intent(out) :: rc + + integer :: status + integer :: rank + integer(kind=ESMF_KIND_I8), pointer :: x_1d(:) + integer(kind=ESMF_KIND_I8), pointer :: x_2d(:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_3d(:,:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_4d(:,:,:,:) + integer(kind=ESMF_KIND_I8), pointer :: x_5d(:,:,:,:,:) + + call ESMF_FieldGet(x, rank=rank, _RC) + + select case (rank) + case (1) + call ESMF_FieldGet(x, farrayPtr = x_1d, _RC) + cptr = c_loc(x_1d) + case (2) + call ESMF_FieldGet(x, farrayPtr = x_2d, _RC) + cptr = c_loc(x_2d) + case (3) + call ESMF_FieldGet(x, farrayPtr = x_3d, _RC) + cptr = c_loc(x_3d) + case (4) + call ESMF_FieldGet(x, farrayPtr = x_4d, _RC) + cptr = c_loc(x_4d) + case (5) + call ESMF_FieldGet(x, farrayPtr = x_5d, _RC) + cptr = c_loc(x_5d) + case default + _FAIL('Unsupported rank in FieldGetCptr().') + end select + + _RETURN(_SUCCESS) + end subroutine get_cptr_i8 + + function get_local_element_count(x, rc) result(element_count) + type(ESMF_Field), intent(inout) :: x + integer, optional, intent(out) :: rc + integer, allocatable :: element_count(:) + + integer :: status + integer :: rank + + call ESMF_FieldGet(x, rank=rank, _RC) + allocate(element_count(rank)) + ! ESMF has a big fat bug with multi tile grids and loal element count + !call ESMF_FieldGet(x, localElementCount=element_count, _RC) + ! until it is fixed we must kluge :( + call MAPL_FieldGetLocalElementCount(x, element_count, _RC) + + _RETURN(_SUCCESS) + end function get_local_element_count + + function get_local_size(x, rc) result(sz) + integer(kind=ESMF_KIND_I8) :: sz + type(ESMF_Field), intent(inout) :: x + integer, optional, intent(out) :: rc + + integer :: status + integer, allocatable :: element_count(:) + + sz = 0 + element_count = FieldGetLocalElementCount(x, _RC) + sz = int(product(element_count), kind=ESMF_KIND_I8) + + _RETURN(_SUCCESS) + end function get_local_size + + subroutine clone(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + character(len=*), parameter :: CLONE_TAG = '_clone' + !type(ESMF_ArraySpec) :: arrayspec + type(ESMF_Grid) :: grid + type(ESMF_StaggerLoc) :: staggerloc + integer, allocatable :: gridToFieldMap(:) + integer, allocatable :: ungriddedLBound(:) + integer, allocatable :: ungriddedUBound(:) + type(ESMF_TypeKind_Flag) :: tk + character(len=ESMF_MAXSTR) :: name + integer :: status + integer :: field_rank, grid_rank,ungrid_size + type(ESMF_Index_Flag) :: index_flag + real(kind=ESMF_KIND_R4), pointer :: VR4_1D(:), VR4_2D(:,:), VR4_3D(:,:,:), VR4_4D(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:), VR8_4D(:,:,:,:) + integer, allocatable :: lc(:) + + call ESMF_FieldGet(x,grid=grid,rank=field_rank,_RC) + lc = get_local_element_count(x,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank,indexFlag=index_flag,_RC) + ungrid_size = field_rank-grid_rank + allocate(gridToFieldMap(grid_rank)) + allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) + call ESMF_FieldGet(x, typekind=tk, name = name, & + staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + + name = trim(name) // CLONE_TAG + + if (index_flag == ESMF_INDEX_USER) then + if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 1) then + allocate(VR4_1d(lc(1)),_STAT) + y = ESMF_FieldCreate(grid,VR4_1d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 1) then + allocate(VR8_1d(lc(1)),_STAT) + y = ESMF_FieldCreate(grid,VR8_1d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 2) then + allocate(VR4_2d(lc(1),lc(2)),_STAT) + y = ESMF_FieldCreate(grid,VR4_2d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 2) then + allocate(VR8_2d(lc(1),lc(2)),_STAT) + y = ESMF_FieldCreate(grid,VR8_2d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 3) then + allocate(VR4_3d(lc(1),lc(2),lc(3)),_STAT) + y = ESMF_FieldCreate(grid,VR4_3d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 3) then + allocate(VR8_3d(lc(1),lc(2),lc(3)),_STAT) + y = ESMF_FieldCreate(grid,VR8_3d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R4 .and. field_rank == 4) then + allocate(VR4_4d(lc(1),lc(2),lc(3),lc(4)),_STAT) + y = ESMF_FieldCreate(grid,VR4_4d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else if (tk == ESMF_TYPEKIND_R8 .and. field_rank == 4) then + allocate(VR8_4d(lc(1),lc(2),lc(3),lc(4)),_STAT) + y = ESMF_FieldCreate(grid,VR8_4d,gridToFieldMap=gridToFieldMap,name=name,_RC) + else + _FAIL( 'unsupported typekind+field_rank') + end if + else + y = ESMF_FieldCreate(grid, tk, staggerloc=staggerloc, & + gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & + ungriddedUBound=ungriddedUBound, name=name, _RC) + end if + + _RETURN(_SUCCESS) + end subroutine clone + + logical function are_conformable_scalar(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + integer :: rank_x, rank_y + integer, dimension(:), allocatable :: count_x, count_y + integer :: status + + conformable = .false. + + call ESMF_FieldGet(x, rank=rank_x, _RC) + call ESMF_FieldGet(y, rank=rank_y, _RC) + + if(rank_x == rank_y) then + count_x = FieldGetLocalElementCount(x, _RC) + count_y = FieldGetLocalElementCount(y, _RC) + conformable = all(count_x == count_y) + end if + + _RETURN(_SUCCESS) + end function are_conformable_scalar + + logical function are_conformable_array(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y(:) + integer, optional, intent(out) :: rc + + integer :: status + integer :: j + logical :: element_not_conformable + + conformable = .false. + element_not_conformable = .false. + + do j = 1, size(y) + element_not_conformable = .not. FieldsAreConformable(x, y(j), _RC) + if(element_not_conformable) return + end do + + conformable = .true. + + _RETURN(_SUCCESS) + end function are_conformable_array + + logical function are_broadcast_conformable(x, y, rc) result(conformable) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + integer :: rank_x, rank_y + 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) + end if + + call ESMF_FieldGet(x, rank=rank_x, _RC) + call ESMF_FieldGet(y, rank=rank_y, _RC) + + if( (rank_x+1) == rank_y) then + count_x = FieldGetLocalElementCount(x, _RC) + count_y = FieldGetLocalElementCount(y, _RC) + conformable = all(count_x == count_y(:rank_y-1)) + end if + + _RETURN(_SUCCESS) + end function are_broadcast_conformable + + logical function are_same_type_kind(x, y, rc) result(same_tk) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + + same_tk = .false. + call ESMF_FieldGet(x, typekind=tk_x, _RC) + call ESMF_FieldGet(y, typekind=tk_y, _RC) + + same_tk = (tk_x == tk_y) + + _RETURN(_SUCCESS) + end function are_same_type_kind + + subroutine verify_typekind_scalar(x, expected_tk, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_TypeKind_Flag), intent(in) :: expected_tk + integer, optional, intent(out) :: rc + + integer :: status + + type(ESMF_TypeKind_Flag) :: found_tk + + call ESMF_FieldGet(x, typekind=found_tk, _RC) + + _ASSERT((found_tk == expected_tk), 'Found incorrect typekind.') + _RETURN(_SUCCESS) + end subroutine verify_typekind_scalar + + subroutine verify_typekind_array(x, expected_tk, rc) + type(ESMF_Field), intent(inout) :: x(:) + type(ESMF_TypeKind_Flag), intent(in) :: expected_tk + integer, optional, intent(out) :: rc + + integer :: status + integer :: i + + do i = 1, size(x) + call verify_typekind(x(i), expected_tk, _RC) + end do + _RETURN(_SUCCESS) + end subroutine verify_typekind_array + + function is_valid_typekind(actual_tk, valid_tks) result(is_valid) + type(ESMF_TypeKind_Flag), intent(in) :: actual_tk + type(ESMF_TypeKind_Flag), intent(in) :: valid_tks(:) + logical :: is_valid + integer :: i + + is_valid = .FALSE. + do i = 1, size(valid_tks) + is_valid = (actual_tk == valid_tks(i)) + if(is_valid) return + end do + + end function is_valid_typekind + + subroutine copy_broadcast(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + type(c_ptr) :: cptr_x, cptr_y + integer(kind=ESMF_KIND_I8) :: n_input,n_extra + integer :: status + logical :: conformable, broadcast + integer, allocatable :: x_shape(:), y_shape(:) + logical :: x_is_double + logical :: y_is_double + character(len=*), parameter :: UNSUPPORTED_TK = & + 'Unsupported typekind in FieldCOPY() for ' + + conformable = FieldsAreConformable(x, y) + if (conformable) then + call copy(x,y,_RC) + _RETURN(_SUCCESS) + end if + broadcast = FieldsAreBroadcastConformable(x,y) + _ASSERT(broadcast, 'FieldCopy() - field can not be broadcast.') + + call MAPL_FieldGetLocalElementCount(x,x_shape,_RC) + call MAPL_FieldGetLocalElementCount(y,y_shape,_RC) + call FieldGetCptr(x, cptr_x, _RC) + call ESMF_FieldGet(x, typekind = tk_x, _RC) + + n_input = product(x_shape) + n_extra = y_shape(size(y_shape)) + + call FieldGetCptr(y, cptr_y, _RC) + call ESMF_FieldGet(y, typekind = tk_y, _RC) + + y_is_double = (tk_y == ESMF_TYPEKIND_R8) + _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') + + x_is_double = (tk_x == ESMF_TYPEKIND_R8) + _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') + + if (y_is_double) then + if (x_is_double) then + call copy_bcast_r8_r8(cptr_x, cptr_y, n_input,n_extra) + else + call copy_bcast_r4_r8(cptr_x, cptr_y, n_input,n_extra) + end if + else + if (x_is_double) then + call copy_bcast_r8_r4(cptr_x, cptr_y, n_input,n_extra) + else + call copy_bcast_r4_r4(cptr_x, cptr_y, n_input,n_extra) + end if + end if + + _RETURN(_SUCCESS) + end subroutine copy_broadcast + + subroutine copy_bcast_r4_r4(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r4_r4 + + subroutine copy_bcast_r4_r8(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r4_r8 + + subroutine copy_bcast_r8_r4(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r8_r4 + + subroutine copy_bcast_r8_r8(cptr_x, cptr_y, n1,n2) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n1,n2 + + integer :: i + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:,:) + + call c_f_pointer(cptr_x, x_ptr, [n1]) + call c_f_pointer(cptr_y, y_ptr, [n1,n2]) + + do i=1,n2 + y_ptr(:,i) = x_ptr + enddo + end subroutine copy_bcast_r8_r8 + + subroutine copy(x, y, rc) + type(ESMF_Field), intent(inout) :: x + type(ESMF_Field), intent(inout) :: y + integer, optional, intent(out) :: rc + + type(ESMF_TypeKind_Flag) :: tk_x, tk_y + type(c_ptr) :: cptr_x, cptr_y + integer(kind=ESMF_KIND_I8) :: n + integer :: status + logical :: conformable + logical :: x_is_double + logical :: y_is_double + character(len=*), parameter :: UNSUPPORTED_TK = & + 'Unsupported typekind in FieldCOPY() for ' + + conformable = FieldsAreConformable(x, y) + !wdb fixme need to pass RC + _ASSERT(conformable, 'FieldCopy() - fields not conformable.') + call FieldGetCptr(x, cptr_x, _RC) + call ESMF_FieldGet(x, typekind = tk_x, _RC) + + n = FieldGetLocalSize(x, _RC) + + call FieldGetCptr(y, cptr_y, _RC) + call ESMF_FieldGet(y, typekind = tk_y, _RC) + + !wdb fixme convert between precisions ? get rid of extra cases + y_is_double = (tk_y == ESMF_TYPEKIND_R8) + _ASSERT(y_is_double .or. (tk_y == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'y.') + + x_is_double = (tk_x == ESMF_TYPEKIND_R8) + _ASSERT(x_is_double .or. (tk_x == ESMF_TYPEKIND_R4), UNSUPPORTED_TK//'x.') + + if (y_is_double) then + if (x_is_double) then + call copy_r8_r8(cptr_x, cptr_y, n) + else + call copy_r4_r8(cptr_x, cptr_y, n) + end if + else + if (x_is_double) then + call copy_r8_r4(cptr_x, cptr_y, n) + else + call copy_r4_r4(cptr_x, cptr_y, n) + end if + end if + + _RETURN(_SUCCESS) + end subroutine copy + + subroutine copy_r4_r4(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r4_r4 + + subroutine copy_r4_r8(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r4_r8 + + subroutine copy_r8_r4(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R4), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r8_r4 + + subroutine copy_r8_r8(cptr_x, cptr_y, n) + type(c_ptr), intent(in) :: cptr_x, cptr_y + integer(ESMF_KIND_I8), intent(in) :: n + + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:) + real(kind=ESMF_KIND_R8), pointer :: y_ptr(:) + + call c_f_pointer(cptr_x, x_ptr, [n]) + call c_f_pointer(cptr_y, y_ptr, [n]) + + y_ptr=x_ptr + end subroutine copy_r8_r8 + +! this procedure must go away as soon as ESMF Fixes their bug + + subroutine MAPL_FieldGetLocalElementCount(field,local_count,rc) + type(ESMF_Field), intent(inout) :: field + integer, allocatable, intent(out) :: local_count(:) + integer, optional, intent(out) :: rc + + integer :: status, rank + type(ESMF_TypeKind_Flag) :: tk + + real(kind=ESMF_KIND_R4), pointer :: r4_1d(:),r4_2d(:,:),r4_3d(:,:,:),r4_4d(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: r8_1d(:),r8_2d(:,:),r8_3d(:,:,:),r8_4d(:,:,:,:) + + call ESMF_FieldGet(field,rank=rank,typekind=tk,_RC) + if (tk == ESMF_TypeKind_R4) then + if (rank==1) then + call ESMF_FieldGet(field,0,farrayptr=r4_1d,_RC) + local_count = shape(r4_1d) + else if (rank ==2) then + call ESMF_FieldGet(field,0,farrayptr=r4_2d,_RC) + local_count = shape(r4_2d) + else if (rank ==3) then + call ESMF_FieldGet(field,0,farrayptr=r4_3d,_RC) + local_count = shape(r4_3d) + else if (rank ==4) then + call ESMF_FieldGet(field,0,farrayptr=r4_4d,_RC) + local_count = shape(r4_4d) + else + _FAIL("Unsupported rank") + end if + else if (tk == ESMF_TypeKind_R8) then + if (rank==1) then + call ESMF_FieldGet(field,0,farrayptr=r8_1d,_RC) + local_count = shape(r8_1d) + else if (rank ==2) then + call ESMF_FieldGet(field,0,farrayptr=r8_2d,_RC) + local_count = shape(r8_2d) + else if (rank ==3) then + call ESMF_FieldGet(field,0,farrayptr=r8_3d,_RC) + local_count = shape(r8_3d) + else if (rank ==4) then + call ESMF_FieldGet(field,0,farrayptr=r8_4d,_RC) + local_count = shape(r8_4d) + else + _FAIL("Unsupported rank") + end if + else + _FAIL("Unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine MAPL_FieldGetLocalElementCount + + function FieldsHaveUndef(fields,rc) result(all_have_undef) + logical :: all_have_undef + type(ESMF_Field), intent(inout) :: fields(:) + integer, optional, intent(out) :: rc + + integer :: status, i + logical :: isPresent + + all_have_undef = .true. + do i =1,size(fields) + call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) + all_have_undef = (all_have_undef .and. isPresent) + enddo + _RETURN(_SUCCESS) + end function + + subroutine GetFieldsUndef_r4(fields,undef_values,rc) + type(ESMF_Field), intent(inout) :: fields(:) + real(kind=ESMF_KIND_R4), allocatable,intent(inout) :: undef_values(:) + integer, optional, intent(out) :: 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) + _ASSERT(isPresent,"missing undef value") + call ESMF_AttributeGet(fields(i),value=undef_values(i),name="missing_value",_RC) + enddo + _RETURN(_SUCCESS) + end subroutine GetFieldsUndef_r4 + + subroutine GetFieldsUndef_r8(fields,undef_values,rc) + type(ESMF_Field), intent(inout) :: fields(:) + real(kind=ESMF_KIND_R8), allocatable,intent(inout) :: undef_values(:) + integer, optional, intent(out) :: 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) + _ASSERT(isPresent,"missing undef value") + call ESMF_AttributeGet(fields(i),value=undef_values(i),name="missing_value",_RC) + enddo + _RETURN(_SUCCESS) + end subroutine GetFieldsUndef_r8 + +subroutine Destroy(Field,RC) + type(ESMF_Field), intent(INOUT) :: Field + integer, optional, intent(OUT ) :: RC + + integer :: STATUS + + real(kind=ESMF_KIND_R4), pointer :: VR4_1D(:), VR4_2D(:,:), VR4_3D(:,:,:), VR4_4D(:,:,:,:) + real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:), VR8_4D(:,:,:,:) + integer :: rank + type(ESMF_TypeKind_Flag) :: tk + logical :: esmf_allocated + + call ESMF_FieldGet(Field,typekind=tk,dimCount=rank,isESMFAllocated=esmf_allocated,_RC) + if (.not. esmf_allocated) then + if (tk == ESMF_TYPEKIND_R4 .and. rank == 1) then + call ESMF_FieldGet(Field,0,VR4_1d,_RC) + deallocate(VR4_1d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 1) then + call ESMF_FieldGet(Field,0,VR8_1d,_RC) + deallocate(VR8_1d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 2) then + call ESMF_FieldGet(Field,0,VR4_2d,_RC) + deallocate(VR4_2d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 2) then + call ESMF_FieldGet(Field,0,VR8_2d,_RC) + deallocate(VR8_2d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 3) then + call ESMF_FieldGet(Field,0,VR4_3D,_RC) + deallocate(VR4_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 3) then + call ESMF_FieldGet(Field,0,VR8_3D,_RC) + deallocate(VR8_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R4 .and. rank == 4) then + call ESMF_FieldGet(Field,0,VR4_4D,_RC) + deallocate(VR4_3d,_STAT) + else if (tk == ESMF_TYPEKIND_R8 .and. rank == 4) then + call ESMF_FieldGet(Field,0,VR8_4D,_RC) + deallocate(VR8_3d,_STAT) + else + _FAIL( 'unsupported typekind+rank') + end if + end if + call ESMF_FieldDestroy(Field,noGarbage = .true., rc=status) + _VERIFY(STATUS) + _RETURN(ESMF_SUCCESS) + + end subroutine Destroy +end module diff --git a/geom/FieldUnaryFunctionTemplate.H b/geom/FieldUnaryFunctionTemplate.H new file mode 100644 index 000000000000..b820c33f1c32 --- /dev/null +++ b/geom/FieldUnaryFunctionTemplate.H @@ -0,0 +1,60 @@ +#define _NAME field +#include "function_overload.macro" + + subroutine _SUB(field_out,field_in,rc) + type(ESMF_Field), intent(inout) :: field_out + type(ESMF_Field), intent(inout) :: field_in + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_Field) :: fields(2) + type(ESMF_TypeKind_Flag) :: tk_in, tk_out + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + real(kind=ESMF_KIND_R4), pointer :: ptr_r4_in(:),ptr_r4_out(:) + real(kind=ESMF_KIND_R8), pointer :: ptr_r8_in(:),ptr_r8_out(:) + logical :: has_undef, conformable + + conformable = FieldsAreConformable(field_in,field_out,_RC) + _ASSERT(conformable,"Fields passed unary function are not conformable") + + fields(1) = field_in + fields(2) = field_out + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field_in,typekind=tk_in,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + _ASSERT(tk_in == tk_out, "For now input and output field must be of same type for a field function") + if (tk_in ==ESMF_TypeKind_R4) then + call assign_fptr(field_in,ptr_r4_in,_RC) + call assign_fptr(field_out,ptr_r4_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(ptr_r4_in /= undef_r4(1)) + ptr_r4_out = _FUNC(ptr_r4_in) + elsewhere + ptr_r4_out = undef_r4(2) + end where + else + ptr_r4_out = _FUNC(ptr_r4_in) + end if + else if (tk_in == ESMF_TypeKind_R8) then + call assign_fptr(field_in,ptr_r8_in,_RC) + call assign_fptr(field_out,ptr_r8_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(ptr_r8_in /= undef_r8(1)) + ptr_r8_out = _FUNC(ptr_r8_in) + elsewhere + ptr_r4_out = undef_r8(2) + end where + else + ptr_r8_out = _FUNC(ptr_r8_in) + end if + else + _FAIL("unsupported type") + end if + _RETURN(_SUCCESS) + end subroutine _SUB + +#include "undo_function_overload.macro" +#undef _NAME diff --git a/geom/FieldUnaryFunctions.F90 b/geom/FieldUnaryFunctions.F90 new file mode 100644 index 000000000000..1cba7b968c3f --- /dev/null +++ b/geom/FieldUnaryFunctions.F90 @@ -0,0 +1,85 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldUnaryFunctions + use ESMF + use MAPL_ExceptionHandling + use MAPL_FieldPointerUtilities + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + implicit none + private + + public :: fieldAbs + public :: fieldExp + public :: fieldLog10 + public :: fieldLog + public :: fieldSqrt + public :: fieldSinh + public :: fieldCosh + public :: fieldTanh + public :: fieldSin + public :: fieldCos + public :: fieldTan + public :: fieldAsin + public :: fieldAcos + public :: fieldAtan + +contains + +#define _FUNC Abs +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Exp +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Log10 +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Log +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sqrt +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sinh +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Cosh +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Tanh +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Sin +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Cos +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Tan +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Asin +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Acos +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +#define _FUNC Atan +#include "FieldUnaryFunctionTemplate.H" +#undef _FUNC + +end module MAPL_FieldUnaryFunctions + diff --git a/geom/FieldUtilities.F90 b/geom/FieldUtilities.F90 new file mode 100644 index 000000000000..130d09222f8e --- /dev/null +++ b/geom/FieldUtilities.F90 @@ -0,0 +1,199 @@ +#include "MAPL_Generic.h" + +module MAPL_FieldUtilities +use ESMF +use MAPL_ErrorHandlingMod +use MAPL_FieldPointerUtilities + +implicit none +private + +public FieldIsConstant +public FieldSet +public FieldNegate +public FieldPow + +interface FieldIsConstant + module procedure FieldIsConstantR4 +end interface + +interface FieldSet + module procedure FieldSet_R4 + module procedure FieldSet_R8 +end interface + +contains + +function FieldIsConstantR4(field,constant_val,rc) result(field_is_constant) + logical :: field_is_constant + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_R4) :: constant_val + integer, optional, intent(out) :: rc + + integer :: status + + real(ESMF_KIND_R4), pointer :: f_ptr_r4(:) + + type(ESMF_TypeKind_Flag) :: type_kind + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + + field_is_constant = .false. + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + field_is_constant = all(f_ptr_r4 == constant_val) + else + _FAIL("constant_val is single precision so you can not check if it is all undef for an R8") + end if + + _RETURN(_SUCCESS) + +end function FieldIsConstantR4 + +subroutine FieldSet_r8(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_r8), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + f_ptr_r4 = constant_val + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + f_ptr_r8 = constant_val + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldSet_r8 + +subroutine FieldSet_r4(field,constant_val,rc) + type(ESMF_Field), intent(inout) :: field + real(kind=ESMF_KIND_r4), intent(in) :: constant_val + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + integer :: status + + call ESMF_FieldGet(field,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + f_ptr_r4 = constant_val + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + f_ptr_r8 = constant_val + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldSet_r4 + +subroutine FieldNegate(field,rc) + type(ESMF_Field), intent(inout) :: field + integer, intent(out), optional :: rc + + type(ESMF_TYPEKIND_FLAG) :: type_kind + real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:) + real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:) + logical :: has_undef + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + integer :: status + type(ESMF_Field) :: fields(1) + + + fields(1) = field + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field,typekind=type_kind,_RC) + if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r4,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(f_ptr_r4 /= undef_r4(1)) + f_ptr_r4 = -f_ptr_r4 + end where + else + f_ptr_r4 = -f_ptr_r4 + end if + else if (type_kind == ESMF_TYPEKIND_R4) then + call assign_fptr(field,f_ptr_r8,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(f_ptr_r8 /= undef_r8(1)) + f_ptr_r8 = -f_ptr_r8 + end where + else + f_ptr_r8 = -f_ptr_r8 + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldNegate + +subroutine FieldPow(field_out,field_in,expo,rc) + type(ESMF_Field), intent(inout) :: field_out + type(ESMF_Field), intent(inout) :: field_in + real, intent(in) :: expo + integer, intent(out), optional :: rc + + real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:) + real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) + type(ESMF_TypeKind_Flag) :: tk_in, tk_out + real(kind=ESMF_KIND_R4), pointer :: ptr_r4_in(:),ptr_r4_out(:) + real(kind=ESMF_KIND_R8), pointer :: ptr_r8_in(:),ptr_r8_out(:) + integer :: status + logical :: has_undef,conformable + type(ESMF_Field) :: fields(2) + + conformable = FieldsAreConformable(field_in,field_out,_RC) + _ASSERT(conformable,"Fields passed power function are not conformable") + + fields(1) = field_in + fields(2) = field_out + has_undef = FieldsHaveUndef(fields,_RC) + call ESMF_FieldGet(field_in,typekind=tk_in,_RC) + call ESMF_FieldGet(field_out,typekind=tk_out,_RC) + _ASSERT(tk_in == tk_out, "For now input and output field must be of same type for a field function") + if (tk_in == ESMF_TYPEKIND_R4) then + call assign_fptr(field_in,ptr_r4_in,_RC) + call assign_fptr(field_out,ptr_r4_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r4,_RC) + where(ptr_r4_in /= undef_r4(1)) + ptr_r4_out = ptr_r4_in**expo + elsewhere + ptr_r4_out = undef_r4(2) + end where + else + ptr_r4_out = ptr_r4_in**expo + end if + else if (tk_in == ESMF_TYPEKIND_R8) then + call assign_fptr(field_in,ptr_r8_in,_RC) + call assign_fptr(field_out,ptr_r8_out,_RC) + if (has_undef) then + call GetFieldsUndef(fields,undef_r8,_RC) + where(ptr_r8_in /= undef_r8(1)) + ptr_r8_out = ptr_r8_in**expo + elsewhere + ptr_r8_out = undef_r8(2) + end where + else + ptr_r8_out = ptr_r8_in**expo + end if + else + _FAIL('unsupported typekind') + end if + _RETURN(ESMF_SUCCESS) +end subroutine FieldPow + +end module + diff --git a/geom/function_overload.macro b/geom/function_overload.macro new file mode 100644 index 000000000000..5b0fd54cf8dc --- /dev/null +++ b/geom/function_overload.macro @@ -0,0 +1,4 @@ +#define _IDENTITY(x)x +#define _SUB __SUB(_NAME,_FUNC) +#define __SUB(A,B) ___SUB(A,B) +#define ___SUB(A,B) _IDENTITY(A)_IDENTITY(B) diff --git a/geom/geom.F90 b/geom/geom.F90 new file mode 100644 index 000000000000..93a803c892d4 --- /dev/null +++ b/geom/geom.F90 @@ -0,0 +1,7 @@ +module MAPL_Geom + use MAPL_FieldUnaryFunctions + use MAPL_FieldBinaryOperations + use MAPL_FieldUtilities + use MAPL_FieldPointerUtilities + use mapl3g_FieldBlas +end module diff --git a/geom/tests/CMakeLists.txt b/geom/tests/CMakeLists.txt index 77847896267d..5a250b45ceed 100644 --- a/geom/tests/CMakeLists.txt +++ b/geom/tests/CMakeLists.txt @@ -2,6 +2,7 @@ set(MODULE_DIRECTORY "${esma_include}/MAPL.geom/tests") set (test_srcs Test_FieldBLAS.pf + Test_FieldArithmetic.pf ) @@ -10,6 +11,7 @@ add_pfunit_ctest(MAPL.geom.tests LINK_LIBRARIES MAPL.geom MAPL.pfunit EXTRA_INITIALIZE Initialize EXTRA_USE MAPL_pFUnit_Initialize + OTHER_SOURCES geom_setup.F90 # OTHER_SOURCES MockUserGridComp.F90 MockItemSpec.F90 MAX_PES 4 ) diff --git a/geom/tests/Test_FieldArithmetic.pf b/geom/tests/Test_FieldArithmetic.pf new file mode 100644 index 000000000000..a0325a702a98 --- /dev/null +++ b/geom/tests/Test_FieldArithmetic.pf @@ -0,0 +1,183 @@ +#include "MAPL_Generic.h" + +module Test_FieldArithmetic + + use geom_setup + use MAPL_FieldUnaryFunctions + use MAPL_FieldBinaryOperations + use MAPL_FieldUtilities + use MAPL_FieldPointerUtilities + use ESMF + use funit + use MAPL_ExceptionHandling + + implicit none + +contains + + @Before + subroutine set_up_data() + implicit none + + integer :: status, rc + + real(kind=ESMF_KIND_R4), parameter :: ADD_R4 = 100.0 + real(kind=ESMF_KIND_R8), parameter :: ADD_R8 = 100.0 + real(kind=ESMF_KIND_R4), allocatable :: y4array(:,:) + real(kind=ESMF_KIND_R8), allocatable :: y8array(:,:) + + allocate(y4array, source=R4_ARRAY_DEFAULT) + 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) + 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) + call ESMF_AttributeSet(yr8,name="missing_value",value=undef,_RC) + + end subroutine set_up_data + + @Test + subroutine test_FieldAddR4() + 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 + + x = XR4 + y = YR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = 2.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 + 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 + + x = XR4 + y = YR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = reshape(source=[2.0,2.0,2.0,undef],shape=[2,2]) + y_ptr = reshape(source=[undef,3.0,3.0,undef],shape=[2,2]) + result_array = x_ptr + result_array = reshape(source=[undef,5.0,5.0,undef],shape=[2,2]) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) + end subroutine test_FieldAddR4_missing + + @Test + subroutine test_FieldAddR8() + 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 + + x = XR8 + y = YR8 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) + + x_ptr = 2.d0 + y_ptr = 3.d0 + result_array = x_ptr + result_array = 5.d0 + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) + end subroutine test_FieldAddR8 + + @Test + subroutine test_FieldPowR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + real :: expo + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + expo = 4.0 + result_array = x_ptr + result_array = 2.0**expo + call FieldPow(x, x, expo, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldPowR4 + + @Test + subroutine test_FieldPowR8() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) + integer :: status, rc + real :: expo + + x = XR8 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.d0 + expo = 4.0 + result_array = x_ptr + result_array = 2.d0**expo + call FieldPow(x, x, expo, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldPowR8 + + @Test + subroutine test_FieldSinR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + result_array = x_ptr + result_array = sin(2.0) + call FieldSin(x, x, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldSinR4 + + @Test + subroutine test_FieldNegR4() + type(ESMF_Field) :: x + real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) + real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) + integer :: status, rc + + x = XR4 + call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) + + x_ptr = 2.0 + result_array = x_ptr + result_array = -2.0 + call FieldNegate(x, _RC) + @assertEqual(x_ptr, result_array) + end subroutine test_FieldNegR4 + +end module Test_FieldArithmetic diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 438e53fc4ffc..a117273fa507 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -3,125 +3,16 @@ module Test_FieldBLAS use mapl3g_FieldBLAS + use geom_setup + use MAPL_FieldPointerUtilities use ESMF use funit use MAPL_ExceptionHandling implicit none - interface mk_field - module procedure mk_field_r4 - module procedure mk_field_r8 - end interface mk_field - - interface initialize_array - module procedure initialize_array_R4 - module procedure initialize_array_R8 - end interface initialize_array - - 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 - - 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) - - type(ESMF_Field) :: XR4 - type(ESMF_Field) :: XR8 - type(ESMF_Field) :: YR4 - type(ESMF_Field) :: YR8 - 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 - character(len=*), intent(in) :: grid_name - integer, optional, intent(out) :: rc - - type(ESMF_Grid) :: grid - - integer :: status - - grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, name = grid_name, _RC) - - _RETURN(_SUCCESS) - end function mk_grid - - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R4) - function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, 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 - - type(ESMF_Field) :: field - real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: ptr - - integer :: status - - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) - call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray - - _RETURN(_SUCCESS) - end function mk_field_r4 - - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R8) - function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, 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 - - type(ESMF_Field) :: field - real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: ptr - - integer :: status - - field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) - call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray - - _RETURN(_SUCCESS) - end function mk_field_r8 - - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, 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(out) :: rc - character(len=*), parameter :: GRID_SUFFIX = '_grid' - character(len=*), parameter :: FIELD_SUFFIX = '_field' - - 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) - field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, _RC) - - _RETURN(_SUCCESS) - end function mk_field_common - @Before subroutine set_up_data() implicit none @@ -145,6 +36,10 @@ contains 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) end subroutine set_up_data @@ -213,6 +108,8 @@ contains x = XR8 y = YR4 + call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) + x_ptr = 4.d0 call FieldCOPY(x, y, _RC) call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) @@ -447,64 +344,41 @@ contains end subroutine test_FieldConvertPrec_R4R8 - !@Test - !wdb fixme not done yet - subroutine test_FieldClone() + @Test + subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc -! type(ESMF_ArraySpec) :: arrayspec -! type(ESMF_Grid) :: grid -! type(ESMF_StaggerLoc) :: staggerloc -! integer, allocatable :: gridToFieldMap(:) -! integer, allocatable :: ungriddedLBound(:) -! integer, allocatable :: ungriddedUBound(:) -! integer, allocatable :: totalLWidth(:,:) -! integer, allocatable :: totalUWidth(:,:) - - x = XR4 - call FieldClone(x, y, _RC) - - end subroutine test_FieldClone - -!wdb setup routines - subroutine initialize_array_R4(x, xmin, xrange) - real(ESMF_KIND_R4), intent(inout) :: x(:,:) - real(ESMF_KIND_R4), intent(in) :: xmin - real(ESMF_KIND_R4), intent(in) :: xrange - integer :: rc - - _ASSERT(xrange > 0, 'Range for random numbers must be positive.') - call random_number(x) - x = xrange * x + xmin - - end subroutine initialize_array_R4 - - subroutine initialize_array_R8(x, xmin, xrange) - real(ESMF_KIND_R8), intent(inout) :: x(:,:) - real(ESMF_KIND_R8), intent(in) :: xmin - real(ESMF_KIND_R8), intent(in) :: xrange - integer :: rc - - _ASSERT(xrange > 0, 'Range for random numbers must be positive.') - call random_number(x) - x = xrange * x + xmin + type(ESMF_TypeKind_Flag) :: tk_x,tk_y + type(ESMF_Grid) :: grid + integer, allocatable :: ungriddedLBound_x(:),ungriddedLBound_y(:) + integer, allocatable :: ungriddedUBound_x(:),ungriddedUBound_y(:) + integer :: grid_rank_x, grid_rank_y + integer :: field_rank_x, field_rank_y + integer :: ungrid_x,ungrid_y - end subroutine initialize_array_R8 + x = XR4_3D - elemental function are_almost_equal(x, y) result(almost_equal) - real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) - real(kind=ESMF_KIND_R8), intent(in) :: x - real(kind=ESMF_KIND_R4), intent(in) :: y - logical :: almost_equal + call ESMF_FieldGet(x,rank=field_rank_x,grid=grid,typekind=tk_x,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_x) + ungrid_x = field_rank_x - grid_rank_x + allocate(ungriddedLBound_x(ungrid_x),ungriddedUBound_x(ungrid_x)) + call ESMF_FieldGet(x,ungriddedLBound=UngriddedLBound_x,ungriddedUBound=UngriddedUBound_x,_RC) - if(y==0) then - almost_equal = (x==0) - else - almost_equal = (abs(x-y)/abs(y) < EPS) - end if + call FieldClone(x, y, _RC) - end function are_almost_equal + call ESMF_FieldGet(y,rank=field_rank_y,grid=grid,typekind=tk_y,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_y) + ungrid_y = field_rank_y - grid_rank_y + allocate(ungriddedLBound_y(ungrid_y),ungriddedUBound_y(ungrid_y)) + call ESMF_FieldGet(y,ungriddedLBound=UngriddedLBound_y,ungriddedUBound=UngriddedUBound_y,_RC) + @assertEqual(field_rank_x,field_rank_y) + @assertEqual(ungrid_x,ungrid_y) + @assertTrue(tk_x==tk_y,"kinds not equal") + @assertEqual(ungriddedLBound_x,ungriddedLBound_y) + @assertEqual(ungriddedUBound_x,ungriddedUBound_y) + + end subroutine test_FieldClone3D @Test subroutine test_almost_equal_scalar() diff --git a/geom/tests/geom_setup.F90 b/geom/tests/geom_setup.F90 new file mode 100644 index 000000000000..e43f6b43c7ad --- /dev/null +++ b/geom/tests/geom_setup.F90 @@ -0,0 +1,186 @@ +#include "MAPL_Generic.h" + +module geom_setup + + use ESMF + use funit + use MAPL_ExceptionHandling + + implicit none + + interface mk_field + module procedure mk_field_r4_2d + module procedure mk_field_r8_2d + end interface mk_field + + interface initialize_array + module procedure initialize_array_r4 + module procedure initialize_array_r8 + end interface + + 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 + 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) + + type(ESMF_Field) :: XR4 + type(ESMF_Field) :: XR8 + type(ESMF_Field) :: YR4 + type(ESMF_Field) :: YR8 + type(ESMF_Field) :: XR4_3D + type(ESMF_Field) :: XR8_3D + type(ESMF_Field) :: YR4_3D + type(ESMF_Field) :: YR8_3D + +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 + character(len=*), intent(in) :: grid_name + integer, optional, intent(out) :: rc + + type(ESMF_Grid) :: grid + + integer :: status + + grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, 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 + character(len=*), intent(in) :: name + integer, optional, intent(in) :: ungriddedLBound(:) + integer, optional, intent(in) :: ungriddedUBound(:) + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + + 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) + + _RETURN(_SUCCESS) + end function mk_field_r4_ungrid + + function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, 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 + + type(ESMF_Field) :: field + real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: ptr + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + call ESMF_FieldGet(field, farrayPtr = ptr, _RC) + ptr => farray + + _RETURN(_SUCCESS) + end function mk_field_r4_2d + + function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, 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 + + type(ESMF_Field) :: field + real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: ptr + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + call ESMF_FieldGet(field, farrayPtr = ptr, _RC) + 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) + 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(:) + integer, optional, intent(out) :: rc + character(len=*), parameter :: GRID_SUFFIX = '_grid' + character(len=*), parameter :: FIELD_SUFFIX = '_field' + + 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) + field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) + + _RETURN(_SUCCESS) + end function mk_field_common + + elemental function are_almost_equal(x, y) result(almost_equal) + real(kind=ESMF_KIND_R4), parameter :: EPS = epsilon(real(1.0, kind=ESMF_KIND_R4)) + real(kind=ESMF_KIND_R8), intent(in) :: x + real(kind=ESMF_KIND_R4), intent(in) :: y + logical :: almost_equal + + if(y==0) then + almost_equal = (x==0) + else + almost_equal = (abs(x-y)/abs(y) < EPS) + end if + + end function are_almost_equal + + subroutine initialize_array_R4(x, xmin, xrange) + real(ESMF_KIND_R4), intent(inout) :: x(:,:) + real(ESMF_KIND_R4), intent(in) :: xmin + real(ESMF_KIND_R4), intent(in) :: xrange + integer :: rc + + _ASSERT(xrange > 0, 'Range for random numbers must be positive.') + call random_number(x) + x = xrange * x + xmin + + end subroutine initialize_array_R4 + + subroutine initialize_array_R8(x, xmin, xrange) + real(ESMF_KIND_R8), intent(inout) :: x(:,:) + real(ESMF_KIND_R8), intent(in) :: xmin + real(ESMF_KIND_R8), intent(in) :: xrange + integer :: rc + + _ASSERT(xrange > 0, 'Range for random numbers must be positive.') + call random_number(x) + x = xrange * x + xmin + + end subroutine initialize_array_R8 + +end module geom_setup diff --git a/geom/undo_function_overload.macro b/geom/undo_function_overload.macro new file mode 100644 index 000000000000..2bb42fc3e1f0 --- /dev/null +++ b/geom/undo_function_overload.macro @@ -0,0 +1,5 @@ +#undef _FUNCN +#undef _IDENTITY +#undef _SUB +#undef __SUB +#undef ___SUB diff --git a/gridcomps/Cap/CMakeLists.txt b/gridcomps/Cap/CMakeLists.txt index 194c41300aaa..c6136b4f63e3 100644 --- a/gridcomps/Cap/CMakeLists.txt +++ b/gridcomps/Cap/CMakeLists.txt @@ -28,9 +28,5 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () target_include_directories (${this} PUBLIC $) -if (BUILD_WITH_FLAP) - target_compile_definitions (${this} PRIVATE USE_FLAP) -endif() - set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 438107c6a54a..dbb2640df122 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -271,15 +271,32 @@ subroutine run_model(this, comm, unusable, rc) integer, optional, intent(out) ::rc integer(kind=INT64) :: start_tick, stop_tick, tick_rate + integer :: rank, ierror integer :: status class(Logger), pointer :: lgr + logical :: file_exists _UNUSED_DUMMY(unusable) call start_timer() - call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, rc=status) - _VERIFY(status) + ! Look for a file called "ESMF.rc" but we want to do this on root and then + ! broadcast the result to the other ranks + + call MPI_COMM_RANK(comm, rank, ierror) + + if (rank == 0) then + inquire(file='ESMF.rc', exist=file_exists) + end if + call MPI_BCAST(file_exists, 1, MPI_LOGICAL, 0, comm, ierror) + + ! 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) + else + call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, _RC) + end if ! Note per ESMF this is a temporary routine as eventually MOAB will ! be the only mesh generator. But until then, this allows us to diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 0088a84b77fd..ef069b2e6e54 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -20,13 +20,11 @@ set (srcs ExtData_IOBundleMod.F90 ExtData_IOBundleVectorMod.F90 ExtDataMasking.F90 - ExtDataYamlNodeStack.F90 - ExtDataYamlNodeWrapper.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.base MAPL.generic MAPL.griddedio TYPE SHARED) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared YAFYAML::yafyaml esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) target_include_directories (${this} PUBLIC $) diff --git a/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 b/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 index 2ade22e98162..f1098f1dc175 100644 --- a/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 +++ b/gridcomps/ExtData2G/ExtDataAbstractFileHandler.F90 @@ -3,7 +3,6 @@ #include "unused_dummy.H" module MAPL_ExtdataAbstractFileHandler use ESMF - use yafYaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ExtDataBracket @@ -28,7 +27,7 @@ module MAPL_ExtdataAbstractFileHandler type(ESMF_Time), allocatable :: valid_range(:) logical :: persist_closest contains - procedure :: initialize + procedure :: initialize procedure :: make_metadata procedure :: get_time_on_file procedure(get_file_bracket), deferred :: get_file_bracket @@ -48,7 +47,7 @@ subroutine get_file_bracket(this, input_time, source_time, bracket, fail_on_miss end subroutine get_file_bracket end interface - + contains subroutine initialize(this,file_series,persist_closest,unusable,rc) @@ -93,7 +92,7 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out type(ESMF_Time), allocatable :: time_series(:) logical :: in_bounds, found_time, wrap_ integer :: i,num_times - + _UNUSED_DUMMY(unusable) if (present(wrap)) then wrap_= .true. @@ -105,7 +104,7 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out _RETURN(_SUCCESS) end if - call this%make_metadata(filename,file_metadata,_RC) + call this%make_metadata(filename,file_metadata,_RC) call file_metadata%get_time_info(timeVector=time_series,_RC) num_times = size(time_series) found_time = .false. @@ -120,14 +119,14 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out exit end if enddo - else + else if (wrap_) then output_time=time_series(num_times) time_index = num_times found_time = .true. - wrap = -1 + wrap = -1 end if - end if + end if else if (bracketside == 'R') then in_bounds = .not.(target_time >= time_series(num_times)) if (in_bounds) then @@ -139,12 +138,12 @@ subroutine get_time_on_file(this,filename,target_time,bracketside,time_index,out exit end if enddo - else + else if (wrap_) then output_time=time_series(1) time_index = 1 found_time = .true. - wrap = 1 + wrap = 1 end if end if else @@ -161,11 +160,11 @@ subroutine make_metadata(this,file,metadata,rc) type(FileMetadataUtils), pointer, intent(inout) :: metadata integer, optional, intent(out ) :: rc type(MAPLDataCollection), pointer :: collection => null() - + Collection => DataCollections%at(this%collection_id) metadata => collection%find(file) _RETURN(_SUCCESS) end subroutine make_metadata - + end module MAPL_ExtdataAbstractFileHandler diff --git a/gridcomps/ExtData2G/ExtDataBracket.F90 b/gridcomps/ExtData2G/ExtDataBracket.F90 index f6fd5dc964f9..9ef4fd590362 100644 --- a/gridcomps/ExtData2G/ExtDataBracket.F90 +++ b/gridcomps/ExtData2G/ExtDataBracket.F90 @@ -8,6 +8,7 @@ module MAPL_ExtDataBracket use MAPL_ExtDataNode use MAPL_ExtDataConstants use MAPL_CommsMod + use MAPL_Geom implicit none private @@ -41,7 +42,7 @@ subroutine reset(this) this%new_file_right=.false. this%new_file_left =.false. end subroutine reset - +! function time_in_bracket(this,time) result(in_bracket) class(ExtDataBracket), intent(in) :: this logical :: in_bracket @@ -178,13 +179,9 @@ subroutine interpolate_to_time(this,field,time,rc) type(ESMF_TimeInterval) :: tinv1, tinv2 real :: alpha - real, pointer :: var2d(:,:) => null() - real, pointer :: var3d(:,:,:) => null() - real, pointer :: var2d_left(:,:) => null() - real, pointer :: var2d_right(:,:) => null() - real, pointer :: var3d_left(:,:,:) => null() - real, pointer :: var3d_right(:,:,:) => null() - integer :: field_rank + real, pointer :: var1d(:) => null() + real, pointer :: var1d_left(:) => null() + real, pointer :: var1d_right(:) => null() integer :: status logical :: right_node_set, left_node_set character(len=ESMF_MAXPATHLEN) :: left_file, right_file @@ -196,81 +193,41 @@ subroutine interpolate_to_time(this,field,time,rc) right_node_set = right_file /= file_not_found left_node_set = left_file /= file_not_found - - call ESMF_FieldGet(field,dimCount=field_rank,_RC) alpha = 0.0 if ( (.not.this%disable_interpolation) .and. (.not.this%intermittent_disable) .and. right_node_set .and. left_node_set) then tinv1 = time - this%left_node%time tinv2 = this%right_node%time - this%left_node%time alpha = tinv1/tinv2 end if - if (field_rank==2) then - - call esmf_fieldget(field,localde=0,farrayptr=var2d,_RC) - if (right_node_set) then - call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var2d_right,_RC) - end if - if (left_node_set) then - call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var2d_left,_RC) - end if - if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then - var2d = var2d_left - else if (right_node_set .and. (time == this%right_node%time)) then - var2d = var2d_right - else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then - where( (var2d_left /= mapl_undef) .and. (var2d_right /= mapl_undef)) - var2d = var2d_left + alpha*(var2d_right-var2d_left) - elsewhere - var2d = mapl_undef - endwhere - else - var2d = mapl_undef - end if - - if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d+this%offset - end if - if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d*this%scale_factor - end if - if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then - where(var2d /= MAPL_UNDEF) var2d=var2d*this%scale_factor+this%offset - end if - - else if (field_rank==3) then - call esmf_fieldget(field,localde=0,farrayptr=var3d,_RC) - if (right_node_set) then - call esmf_fieldget(this%right_node%field,localde=0,farrayptr=var3d_right,_RC) - end if - if (left_node_set) then - call esmf_fieldget(this%left_node%field,localde=0,farrayptr=var3d_left,_RC) - end if - if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation) ) then - var3d = var3d_left - else if ( right_node_set .and. (time == this%right_node%time) ) then - var3d = var3d_right - else if (right_node_set .and. (time == this%right_node%time)) then - var3d = var3d_right - else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) )then - where( (var3d_left /= mapl_undef) .and. (var3d_right /= mapl_undef)) - var3d = var3d_left + alpha*(var3d_right-var3d_left) - elsewhere - var3d = mapl_undef - endwhere - else - var3d = mapl_undef - end if - - if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d+this%offset - end if - if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d*this%scale_factor - end if - if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then - where(var3d /= MAPL_UNDEF) var3d=var3d*this%scale_factor+this%offset - end if + call assign_fptr(field,var1d,_RC) + if (right_node_set) then + call assign_fptr(this%right_node%field,var1d_right,_RC) + end if + if (left_node_set) then + call assign_fptr(this%left_node%field,var1d_left,_RC) + end if + if ( left_node_set .and. (time == this%left_node%time .or. this%disable_interpolation)) then + var1d = var1d_left + else if (right_node_set .and. (time == this%right_node%time)) then + var1d = var1d_right + else if ( (left_node_set .and. right_node_set) .and. (.not.this%exact) ) then + where( (var1d_left /= mapl_undef) .and. (var1d_right /= mapl_undef)) + var1d = var1d_left + alpha*(var1d_right-var1d_left) + elsewhere + var1d = mapl_undef + endwhere + else + var1d = mapl_undef + end if + if (this%scale_factor == 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d+this%offset + end if + if (this%scale_factor /= 0.0 .and. this%offset == 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor + end if + if (this%scale_factor /= 0.0 .and. this%offset /= 0.0) then + where(var1d /= MAPL_UNDEF) var1d=var1d*this%scale_factor+this%offset end if _RETURN(_SUCCESS) @@ -281,24 +238,15 @@ subroutine swap_node_fields(this,rc) class(ExtDataBracket), intent(inout) :: this integer, optional, intent(out) :: rc integer :: status - integer :: field_rank - real, pointer :: var3d_left(:,:,:),var3d_right(:,:,:) - real, pointer :: var2d_left(:,:),var2d_right(:,:) + real, pointer :: left_ptr(:), right_ptr(:) logical :: left_created, right_created left_created = ESMF_FieldIsCreated(this%left_node%field,_RC) right_created = ESMF_FieldIsCreated(this%right_node%field,_RC) if (left_created .and. right_created) then - call ESMF_FieldGet(this%left_node%field,dimCount=field_rank,_RC) - if (field_rank == 2) then - call ESMF_FieldGet(this%right_node%field,localDE=0,farrayPtr=var2d_right,_RC) - call ESMF_FieldGet(this%left_node%field,localDE=0,farrayPtr=var2d_left,_RC) - var2d_left = var2d_right - else if (field_rank ==3) then - call ESMF_FieldGet(this%right_node%field,localDE=0,farrayPtr=var3d_right,_RC) - call ESMF_FieldGet(this%left_node%field,localDE=0,farrayPtr=var3d_left,_RC) - var3d_left = var3d_right - end if + call assign_fptr(this%left_node%field,left_ptr,_RC) + call assign_fptr(this%right_node%field,right_ptr,_RC) + left_ptr = right_ptr end if _RETURN(_SUCCESS) end subroutine swap_node_fields diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index cc20edc46671..086476a761fe 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -1,7 +1,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataConfig use ESMF - use yaFyaml use PFIO use gFTL_StringVector use MAPL_KeywordEnforcerMod @@ -17,8 +16,6 @@ module MAPL_ExtDataConfig use MAPL_ExtDataTimeSampleMap use MAPL_TimeStringConversion use MAPL_ExtDataMask - use MAPL_ExtDataYamlNodeStack - use MAPL_ExtDataYamlNodeWrapper implicit none private @@ -50,15 +47,12 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - type(Parser) :: p -#ifndef __GFORTRAN__ - class(YAML_Node), allocatable :: config -#else - integer :: my_stack -#endif - class(YAML_Node), pointer :: subcfg, ds_config, rule_config, derived_config, sample_config, subconfigs, rule_map - class(NodeIterator), allocatable :: iter - character(len=:), pointer :: key + type(ESMF_HConfig) :: input_config + type(ESMF_HConfig) :: temp_configs + type(ESMF_HConfigIter) :: hconfigIter,hconfigIterBegin,hconfigIterEnd + character(len=:), allocatable :: hconfig_key + type(ESMF_HConfig) :: single_sample,single_collection,single_export,rule_map,hconfig_val + character(len=:), allocatable :: new_key type(ExtDataFileStream) :: ds type(ExtDataDerived) :: derived @@ -66,124 +60,103 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ integer :: status type(ExtDataFileStream), pointer :: temp_ds - type(ExtDataTimeSample), pointer :: temp_ts type(ExtDataDerived), pointer :: temp_derived - character(len=:), pointer :: sub_file integer :: i,num_rules integer, allocatable :: sorted_rules(:) character(len=1) :: i_char logical :: file_found + logical :: is_right_type + character(len=:), allocatable :: sub_configs(:) _UNUSED_DUMMY(unusable) inquire(file=trim(config_file),exist=file_found) _ASSERT(file_found,"could not find: "//trim(config_file)) -#ifdef __GFORTRAN__ - stack_depth = stack_depth + 1 - _ASSERT(stack_depth <= MAX_FILE_DEPTH,"yaml config stack too small") - my_stack = stack_depth - associate(config => yaml_node_stack(my_stack)%a_yaml_node) -#endif - p = Parser('core') - config = p%load(config_file,rc=status) - if (status/=_SUCCESS) then - _FAIL("Error parsing "//trim(config_file)) - end if + input_config = ESMF_HConfigCreate(filename=trim(config_file),_RC) - if (config%has("subconfigs")) then - subconfigs => config%at("subconfigs") - _ASSERT(subconfigs%is_sequence(),'subconfigs is not a sequence') - do i=1,subconfigs%size() - sub_file => to_string(subconfigs%at(i)) - call new_ExtDataConfig_from_yaml(ext_config,sub_file,current_time,rc=status) - _VERIFY(status) - end do -#ifdef __GFORTRAN__ - deallocate(config) - config = p%load(config_file,rc=status) -#endif + if (ESMF_HConfigIsDefined(input_config,keyString="subconfigs")) then + is_right_type = ESMF_HConfigIsSequence(input_config,keyString='subconfigs',_RC) + _ASSERT(is_right_type,"subconfig list is not a sequence") + sub_configs = ESMF_HConfigAsStringSeq(input_config,ESMF_MAXPATHLEN,keyString='subconfigs',_RC) + do i=1,size(sub_configs) + call new_ExtDataConfig_from_yaml(ext_config,sub_configs(i),current_time,_RC) + enddo end if - - - if (config%has("Samplings")) then - sample_config => config%of("Samplings") - iter = sample_config%begin() - do while (iter /= sample_config%end()) - key => to_string(iter%first(),_RC) - temp_ts => ext_config%sample_map%at(key) - _ASSERT(.not.associated(temp_ts),"defined duplicate named sample key") - subcfg => iter%second() - ts = ExtDataTimeSample(subcfg,_RC) - _VERIFY(status) - call ext_config%sample_map%insert(trim(key),ts) - call iter%next() + + if (ESMF_HConfigIsDefined(input_config,keyString="Samplings")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Samplings",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + single_sample = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + ts = ExtDataTimeSample(single_sample,_RC) + call ext_config%sample_map%insert(trim(hconfig_key),ts) enddo end if - if (config%has("Collections")) then - ds_config => config%of("Collections") - iter = ds_config%begin() - do while (iter /= ds_config%end()) - key => to_string(iter%first(),_RC) - temp_ds => ext_config%file_stream_map%at(key) + if (ESMF_HConfigIsDefined(input_config,keyString="Collections")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Collections",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + temp_ds => ext_config%file_stream_map%at(hconfig_key) _ASSERT(.not.associated(temp_ds),"defined duplicate named collection") - subcfg => iter%second() - ds = ExtDataFileStream(subcfg,current_time,_RC) - call ext_config%file_stream_map%insert(trim(key),ds) - call iter%next() + single_collection = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + ds = ExtDataFileStream(single_collection,current_time,_RC) + call ext_config%file_stream_map%insert(trim(hconfig_key),ds) enddo end if - if (config%has("Exports")) then - rule_config => config%of("Exports") - iter = rule_config%begin() - do while (iter /= rule_config%end()) - key => to_string(iter%first(),_RC) - subcfg => iter%second() - if (subcfg%is_mapping()) then - call ext_config%add_new_rule(key,subcfg,_RC) - else if (subcfg%is_sequence()) then - sorted_rules = sort_rules_by_start(subcfg,_RC) - num_rules = subcfg%size() + if (ESMF_HConfigIsDefined(input_config,keyString="Exports")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Exports",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + hconfig_val = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + if (ESMF_HConfigIsMap(hconfig_val)) then + call ext_config%add_new_rule(hconfig_key,hconfig_val,_RC) + else if (ESMF_HConfigIsSequence(hconfig_val)) then + sorted_rules = sort_rules_by_start(hconfig_val,_RC) + num_rules = ESMF_HConfigGetSize(hconfig_val,_RC) do i=1,num_rules - rule_map => subcfg%of(sorted_rules(i)) + rule_map = ESMF_HConfigCreateAt(hconfig_val,index=sorted_rules(i),_RC) write(i_char,'(I1)')i - new_key = key//rule_sep//i_char + new_key = hconfig_key//rule_sep//i_char call ext_config%add_new_rule(new_key,rule_map,multi_rule=.true.,_RC) enddo else - _FAIL("Exports must be sequence or map") + _FAIL("Unsupported type") end if - call iter%next() enddo end if - if (config%has("Derived")) then - derived_config => config%at("Derived") - iter = derived_config%begin() - do while (iter /= derived_config%end()) - call derived%set_defaults(rc=status) - _VERIFY(status) - key => to_string(iter%first(),_RC) - subcfg => iter%second() - derived = ExtDataDerived(subcfg,_RC) - temp_derived => ext_config%derived_map%at(trim(key)) + if (ESMF_HConfigIsDefined(input_config,keyString="Derived")) then + temp_configs = ESMF_HConfigCreateAt(input_config,keyString="Derived",_RC) + hconfigIter = ESMF_HConfigIterBegin(temp_configs) + hconfigIterBegin = ESMF_HConfigIterBegin(temp_configs) + hconfigIterEnd = ESMF_HConfigIterEnd(temp_configs) + do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd)) + hconfig_key = ESMF_HConfigAsStringMapKey(hconfigIter,_RC) + single_export = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) + derived = ExtDataDerived(single_export,_RC) + temp_derived => ext_config%derived_map%at(trim(hconfig_key)) _ASSERT(.not.associated(temp_derived),"duplicated derived entry key") - call ext_config%derived_map%insert(trim(key),derived) - call iter%next() - enddo + call ext_config%derived_map%insert(trim(hconfig_key),derived) + end do end if - if (config%has("debug")) then - call config%get(ext_config%debug,"debug",rc=status) - _VERIFY(status) + if (ESMF_HConfigIsDefined(input_config,keyString="debug") )then + ext_config%debug = ESMF_HConfigAsI4(input_config,keyString="debug",_RC) end if -#ifdef __GFORTRAN__ - end associate -#endif _RETURN(_SUCCESS) end subroutine new_ExtDataConfig_from_yaml @@ -250,27 +223,28 @@ function get_time_range(this,item_name,rc) result(time_range) _RETURN(_SUCCESS) end function get_time_range - function sort_rules_by_start(yaml_sequence,rc) result(sorted_index) + function sort_rules_by_start(hconfig_sequence,rc) result(sorted_index) integer, allocatable :: sorted_index(:) - class(YAML_Node), intent(inout) :: yaml_sequence + type(ESMF_HConfig), intent(inout) :: hconfig_sequence integer, optional, intent(out) :: rc integer :: num_rules,i,j,i_temp,imin logical :: found_start - class(YAML_Node), pointer :: yaml_dict + type(ESMF_HConfig) :: hconfig_dict character(len=:), allocatable :: start_time type(ESMF_Time), allocatable :: start_times(:) type(ESMF_Time) :: temp_time + integer :: status - num_rules = yaml_sequence%size() + num_rules = ESMF_HConfigGetSize(hconfig_sequence,_RC) allocate(start_times(num_rules)) allocate(sorted_index(num_rules),source=[(i,i=1,num_rules)]) do i=1,num_rules - yaml_dict => yaml_sequence%of(i) - found_start = yaml_dict%has("starting") + hconfig_dict = ESMF_HConfigCreateAt(hconfig_sequence,index=i,_RC) + found_start = ESMF_HConfigIsDefined(hconfig_dict,keyString="starting") _ASSERT(found_start,"no start key in multirule export of extdata") - start_time = yaml_dict%of("starting") + start_time = ESMF_HConfigAsString(hconfig_dict,keyString="starting",_RC) start_times(i) = string_to_esmf_time(start_time) enddo @@ -344,7 +318,7 @@ end function get_item_type subroutine add_new_rule(this,key,export_rule,multi_rule,rc) class(ExtDataConfig), intent(inout) :: this character(len=*), intent(in) :: key - class(YAML_Node), intent(in) :: export_rule + type(ESMF_HConfig), intent(in) :: export_rule logical, optional, intent(in) :: multi_rule integer, intent(out), optional :: rc @@ -394,8 +368,6 @@ function get_extra_derived_items(this,primary_items,derived_items,rc) result(nee type(ExtDataDerived), pointer :: derived_item type(StringVector) :: variables_in_expression character(len=:), pointer :: sval,derived_name - character(len=:), allocatable :: base_name - type(ExtDataRule), pointer :: rule logical :: in_primary,found_rule integer :: i @@ -446,7 +418,7 @@ function has_rule_for(this,base_name,rc) result(found_rule) found_rule = (key(:rule_sep_loc-1) == base_name) else found_rule = (key == base_name) - end if + end if if (found_rule) exit call iter%next() enddo diff --git a/gridcomps/ExtData2G/ExtDataDerived.F90 b/gridcomps/ExtData2G/ExtDataDerived.F90 index f036898ce6b0..e538f220925c 100644 --- a/gridcomps/ExtData2G/ExtDataDerived.F90 +++ b/gridcomps/ExtData2G/ExtDataDerived.F90 @@ -2,7 +2,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataDerived use ESMF - use yaFyaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use gFTL_StringVector @@ -27,7 +26,7 @@ module MAPL_ExtDataDerived contains function new_ExtDataDerived(config,unusable,rc) result(rule) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -39,17 +38,17 @@ function new_ExtDataDerived(config,unusable,rc) result(rule) if (allocated(tempc)) deallocate(tempc) - is_present = config%has("function") - _ASSERT(is_present,"no expression found in derived entry") - call config%get(tempc,"function",rc=status) - _VERIFY(status) - rule%expression=tempc + is_present = ESMF_HConfigIsDefined(config,keyString="function",_RC) + _ASSERT(is_present,"no expression found in derived entry") + if (is_present) then + tempc = ESMF_HConfigAsString(config,keyString="function",_RC) + rule%expression=tempc + end if if (allocated(tempc)) deallocate(tempc) - is_present = config%has("sample") + is_present = ESMF_HConfigIsDefined(config,keyString="sample",_RC) if (is_present) then - call config%get(tempc,"sample",rc=status) - _VERIFY(status) + tempc = ESMF_HConfigAsString(config,keyString="sample",_RC) rule%sample_key=tempc end if @@ -67,14 +66,14 @@ function get_variables_in_expression(this,rc) result(variables_in_expression) if (index(this%expression,"mask")/=0) then allocate(temp_mask) temp_mask = ExtDataMask(this%expression) - variables_in_expression = temp_mask%get_mask_variables(_RC) + variables_in_expression = temp_mask%get_mask_variables(_RC) else variables_in_expression = parser_variables_in_expression(this%expression,_RC) end if _RETURN(_SUCCESS) end function - + subroutine set_defaults(this,unusable,rc) class(ExtDataDerived), intent(inout), target :: this @@ -90,7 +89,7 @@ subroutine display(this) class(ExtDataDerived) :: this write(*,*)"function: ",trim(this%expression) end subroutine display - + end module MAPL_ExtDataDerived module MAPL_ExtDataDerivedMap diff --git a/gridcomps/ExtData2G/ExtDataFileStream.F90 b/gridcomps/ExtData2G/ExtDataFileStream.F90 index fa4ce0ec7810..ba6523224a34 100644 --- a/gridcomps/ExtData2G/ExtDataFileStream.F90 +++ b/gridcomps/ExtData2G/ExtDataFileStream.F90 @@ -2,7 +2,6 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataFileStream use ESMF - use yaFyaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_TimeStringConversion @@ -15,7 +14,7 @@ module MAPL_ExtDataFileStream private type, public :: ExtDataFileStream - character(:), allocatable :: file_template + character(len=:), allocatable :: file_template type(ESMF_TimeInterval) :: frequency type(ESMF_Time) :: reff_time integer :: collection_id @@ -30,8 +29,8 @@ module MAPL_ExtDataFileStream end interface ExtDataFileStream contains - function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) - class(Yaml_node), intent(in) :: config + function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) + type(ESMF_HConfig), intent(in) :: config type(ESMF_Time), intent(in) :: current_time class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -46,18 +45,15 @@ function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) _UNUSED_DUMMY(unusable) - if (config%is_scalar()) then - - else if (config%is_mapping()) then - is_present = config%has("template") - _ASSERT(is_present,"no file template in the collection") - if (is_present) then - call config%get(data_set%file_template,"template",rc=status) - _VERIFY(status) - file_frequency = get_string_with_default(config,"freq") - file_reff_time = get_string_with_default(config,"ref_time") - range_str = get_string_with_default(config,"valid_range") - end if + + is_present = ESMF_HConfigIsDefined(config,keyString="template",_RC) + _ASSERT(is_present,"no file template in the collection") + + if (is_present) then + data_set%file_template = ESMF_HConfigAsString(config,keyString="template",_RC) + file_frequency = get_string_with_default(config,"freq") + file_reff_time = get_string_with_default(config,"ref_time") + range_str = get_string_with_default(config,"valid_range") end if if (file_frequency /= '') then @@ -142,12 +138,12 @@ function new_ExtDataFileStream(config,current_time,unusable,rc) result(data_set) contains function get_string_with_default(config,selector) result(string) - class(Yaml_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config character(len=*), intent(In) :: selector character(len=:), allocatable :: string - if (config%has(selector)) then - string=config%of(selector) + if (ESMF_HConfigIsDefined(config,keyString=selector)) then + string = ESMF_HConfigAsString(config,keyString=selector,_RC) else string='' end if @@ -163,7 +159,7 @@ subroutine detect_metadata(this,metadata_out,time,multi_rule,get_range,rc) logical, optional, intent(in) :: get_range integer, optional, intent(out) :: rc - logical :: get_range_ + logical :: get_range_ type(MAPLDataCollection), pointer :: collection type(FileMetadataUtils), pointer :: metadata type(ESMF_Time), allocatable :: time_series(:) diff --git a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 index 999ae4cf84a3..957f6d7cc02a 100644 --- a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 +++ b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 @@ -61,6 +61,7 @@ MODULE MAPL_ExtDataGridComp2G use pflogger, only: logging, Logger use MAPL_ExtDataLogger use MAPL_ExtDataConstants + use gFTL_StringIntegerMap IMPLICIT NONE PRIVATE @@ -1346,7 +1347,7 @@ subroutine MAPL_ExtDataCreateCFIO(IOBundles, rc) bundle_iter = IOBundles%begin() do while (bundle_iter /= IOBundles%end()) io_bundle => bundle_iter%get() - call io_bundle%make_cfio(_RC) + call io_bundle%make_io(_RC) call bundle_iter%next() enddo @@ -1386,8 +1387,11 @@ subroutine MAPL_ExtDataPrefetch(IOBundles,rc) do n = 1, nfiles io_bundle => IOBundles%at(n) - call io_bundle%cfio%request_data_from_file(io_bundle%file_name,io_bundle%time_index,rc=status) - _VERIFY(status) + if (io_bundle%on_tiles) then + call io_bundle%tile_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) + else + call io_bundle%grid_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) + end if enddo _RETURN(ESMF_SUCCESS) @@ -1406,8 +1410,11 @@ subroutine MAPL_ExtDataReadPrefetch(IOBundles,rc) nfiles = IOBundles%size() do n=1, nfiles io_bundle => IOBundles%at(n) - call io_bundle%cfio%process_data_from_file(rc=status) - _VERIFY(status) + if (io_bundle%on_tiles) then + call io_bundle%tile_io%process_data_from_file(_RC) + else + call io_bundle%grid_io%process_data_from_file(_RC) + end if enddo _RETURN(ESMF_SUCCESS) @@ -1453,13 +1460,19 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,rc) logical :: update character(len=ESMF_MAXPATHLEN) :: current_file integer :: time_index + type(StringIntegerMap), pointer :: dimensions + integer, pointer :: tile_size + logical :: on_tiles + dimensions => item%file_metadata%get_dimensions() + tile_size => dimensions%at("tile_index") + on_tiles = associated(tile_size) call item%modelGridFields%comp1%get_parameters('L',update=update,file=current_file,time_index=time_index) if (update) then if (trim(current_file)/=file_not_found) then call itemsL%push_back(item%fileVars) io_bundle = ExtDataNG_IOBundle(MAPL_ExtDataLeft, entry_num, current_file, time_index, item%trans, item%fracval, item%file_template, & - item%pfioCollection_id,item%iclient_collection_id,itemsL,rc=status) + item%pfioCollection_id,item%iclient_collection_id,itemsL,on_tiles,rc=status) _VERIFY(status) call IOBundles%push_back(io_bundle) call extdata_lgr%info('%a updated L bracket with: %a at time index %i3 ',item%name, current_file, time_index) @@ -1470,7 +1483,7 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,rc) if (trim(current_file)/=file_not_found) then call itemsR%push_back(item%fileVars) io_bundle = ExtDataNG_IOBundle(MAPL_ExtDataRight, entry_num, current_file, time_index, item%trans, item%fracval, item%file_template, & - item%pfioCollection_id,item%iclient_collection_id,itemsR,rc=status) + item%pfioCollection_id,item%iclient_collection_id,itemsR,on_tiles,rc=status) _VERIFY(status) call IOBundles%push_back(io_bundle) call extdata_lgr%info('%a updated R bracket with: %a at time index %i3 ',item%name,current_file, time_index) @@ -1768,19 +1781,14 @@ function am_i_running(yaml_file,rc) result(am_running) character(len=*), intent(in) :: yaml_file integer, intent(out), optional :: rc - type(Parser) :: p - class(YAML_Node), allocatable :: config + type(ESMF_HConfig), allocatable :: config integer :: status am_running=.true. - p = Parser('core') - config = p%load(yaml_file,rc=status) - if (status/=_SUCCESS) then - _FAIL("Error parsing: "//trim(yaml_file)) - end if - if (config%has("USE_EXTDATA")) then - am_running = config%of("USE_EXTDATA") + config = ESMF_HConfigCreate(filename = trim(yaml_file),_RC) + if (ESMF_HConfigIsDefined(config,keyString="USE_EXTDATA")) then + am_running = ESMF_HConfigAsLogical(config,keyString="USE_EXTDATA",_RC) end if _RETURN(_SUCCESS) diff --git a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 index f84d2936eafe..f6e4533b2f2c 100644 --- a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 +++ b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 @@ -4,7 +4,6 @@ module MAPL_ExtDataOldTypesCreator use ESMF use MAPL_BaseMod - use yafYaml use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ExtDataTypeDef diff --git a/gridcomps/ExtData2G/ExtDataRule.F90 b/gridcomps/ExtData2G/ExtDataRule.F90 index 82af19610df5..44b4e7a752f8 100644 --- a/gridcomps/ExtData2G/ExtDataRule.F90 +++ b/gridcomps/ExtData2G/ExtDataRule.F90 @@ -1,6 +1,5 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataRule - use yaFyaml use ESMF use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling @@ -34,7 +33,7 @@ module MAPL_ExtDataRule contains function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(rule) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config character(len=*), intent(in) :: key type(ExtDataTimeSampleMap) :: sample_map class(KeywordEnforcer), optional, intent(in) :: unusable @@ -44,7 +43,7 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru type(ExtDataRule) :: rule logical :: collection_present, variable_present integer :: status - class(YAML_Node), pointer ::config1 + type(ESMF_HConfig) ::config1 character(len=:), allocatable :: tempc type(ExtDataTimeSample) :: ts logical :: usable_multi_rule @@ -57,61 +56,61 @@ function new_ExtDataRule(config,sample_map,key,unusable,multi_rule,rc) result(ru end if if (allocated(tempc)) deallocate(tempc) - collection_present = config%has("collection") + collection_present = ESMF_HConfigIsDefined(config,keyString="collection") _ASSERT(collection_present,"no collection present in ExtData export") - rule%collection = config%of("collection") + rule%collection = ESMF_HConfigAsString(config,keyString="collection",_RC) if (allocated(tempc)) deallocate(tempc) - variable_present = config%has("variable") + variable_present = ESMF_HConfigIsDefined(config,keyString="variable") if (index(rule%collection,"/dev/null")==0) then _ASSERT(variable_present,"no variable present in ExtData export") end if if (variable_present) then - tempc = config%of("variable") + tempc = ESMF_HConfigAsString(config,keyString="variable",_RC) rule%file_var=tempc else rule%file_var='null' end if - if (config%has("sample")) then - config1=>config%at("sample") - if (config1%is_mapping()) then + if (ESMF_HConfigIsDefined(config,keyString="sample")) then + + config1 = ESMF_HConfigCreateAt(config,keyString="sample",_RC) + if (ESMF_HConfigIsMap(config1)) then ts = ExtDataTimeSample(config1,_RC) call sample_map%insert(trim(key)//"_sample",ts) rule%sample_key=trim(key)//"_sample" - else if (config1%is_string()) then - rule%sample_key=config1 else - _FAIL("sample entry unsupported") + rule%sample_key=ESMF_HConfigAsString(config1,_RC) end if - else + else rule%sample_key = "" end if if (allocated(rule%linear_trans)) deallocate(rule%linear_trans) - if (config%has("linear_transformation")) then - call config%get(rule%linear_trans,"linear_transformation") + if (ESMF_HConfigIsDefined(config,keyString="linear_transformation")) then + allocate(rule%linear_trans(2)) + rule%linear_trans = ESMF_HConfigAsR4Seq(config,keyString="linear_transformation",_RC) else allocate(rule%linear_trans,source=[0.0,0.0]) end if - + if (allocated(tempc)) deallocate(tempc) - if (config%has("regrid")) then - tempc = config%of("regrid") + if (ESMF_HConfigIsDefined(config,keyString="regrid")) then + tempc = ESMF_HConfigAsString(config,keyString="regrid",_RC) rule%regrid_method=tempc - else + else rule%regrid_method="BILINEAR" end if - if (config%has("starting")) then - tempc = config%of("starting") + if (ESMF_HConfigIsDefined(config,keyString="starting")) then + tempc = ESMF_HConfigAsString(config,keyString="starting",_RC) rule%start_time = tempc end if - if (config%has("fail_on_missing_file")) then - rule%fail_on_missing_file = config%of("fail_on_missing_file") - end if - + if (ESMF_HConfigIsDefined(config,keyString="fail_on_missing_file")) then + rule%fail_on_missing_file = ESMF_HConfigAsLogical(config,keyString="fail_on_missing_file",_RC) + end if + rule%multi_rule=usable_multi_rule _RETURN(_SUCCESS) @@ -137,7 +136,7 @@ subroutine split_vector(this,original_key,ucomp,vcomp,unusable,rc) integer, optional, intent(out) :: rc integer :: semi_pos character(len=:),allocatable :: uname,vname - + _UNUSED_DUMMY(unusable) semi_pos = index(this%file_var,";") diff --git a/gridcomps/ExtData2G/ExtDataSample.F90 b/gridcomps/ExtData2G/ExtDataSample.F90 index 5e19e22fc9ff..e7d9c6ce168f 100644 --- a/gridcomps/ExtData2G/ExtDataSample.F90 +++ b/gridcomps/ExtData2G/ExtDataSample.F90 @@ -1,6 +1,5 @@ #include "MAPL_ErrLog.h" module MAPL_ExtDataTimeSample - use yaFyaml use ESMF use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling @@ -27,7 +26,7 @@ module MAPL_ExtDataTimeSample contains function new_ExtDataTimeSample(config,unusable,rc) result(TimeSample) - class(YAML_Node), intent(in) :: config + type(ESMF_HConfig), intent(in) :: config class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -39,38 +38,46 @@ function new_ExtDataTimeSample(config,unusable,rc) result(TimeSample) call TimeSample%set_defaults() - if (config%has("extrapolation")) TimeSample%extrap_outside=config%of("extrapolation") + if (ESMF_HConfigIsDefined(config,keyString="extrapolation")) then + TimeSample%extrap_outside=ESMF_HConfigAsString(config,keyString="extrapolation",_RC) + end if - if (config%has("time_interpolation")) then - TimeSample%time_interpolation = config%of("time_interpolation") + if (ESMF_HConfigIsDefined(config,keyString="time_interpolation")) then + TimeSample%time_interpolation = ESMF_HConfigAsLogical(config,keyString="time_interpolation",_RC) else TimeSample%time_interpolation = .true. end if - if (config%has("exact")) then - TimeSample%exact = config%of("exact") + + if (ESMF_HConfigIsDefined(config,keyString="exact")) then + TimeSample%exact = ESMF_HConfigAsLogical(config,keyString="exact",_RC) else TimeSample%exact = .false. end if - if (config%has("update_reference_time")) TimeSample%refresh_time=config%of("update_reference_time") + if (ESMF_HConfigIsDefined(config,keyString="update_reference_time")) then + TimeSample%refresh_time = ESMF_HConfigAsString(config,keyString="update_reference_time",_RC) + end if - if (config%has("update_reference_time")) TimeSample%refresh_frequency=config%of("update_frequency") + if (ESMF_HConfigIsDefined(config,keyString="update_frequency")) then + TimeSample%refresh_frequency = ESMF_HConfigAsString(config,keyString="update_frequency",_RC) + end if - if (config%has("update_offset")) TimeSample%refresh_offset=config%of("update_offset") + if (ESMF_HConfigIsDefined(config,keyString="update_offset")) then + TimeSample%refresh_offset = ESMF_HConfigAsString(config,keyString="update_offset",_RC) + end if - if (config%has("source_time")) then - call config%get(source_str,"source_time",rc=status) - _VERIFY(status) + if (ESMF_HConfigIsDefined(config,keyString="source_time")) then + source_str = ESMF_HConfigAsString(config,keyString="source_time",_RC) if (allocated(TimeSample%source_time)) deallocate(TimeSample%source_time) idx = index(source_str,'/') _ASSERT(idx/=0,'invalid specification of source_time') allocate(TimeSample%source_time(2)) TimeSample%source_time(1)=string_to_esmf_time(source_str(:idx-1)) TimeSample%source_time(2)=string_to_esmf_time(source_str(idx+1:)) - else + else if (.not.allocated(TimeSample%source_time)) allocate(TimeSample%source_time(0)) end if - + _RETURN(_SUCCESS) end function new_ExtDataTimeSample @@ -81,14 +88,14 @@ subroutine set_defaults(this,unusable,rc) class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status + integer :: status _UNUSED_DUMMY(unusable) this%time_interpolation=.true. this%extrap_outside='none' this%refresh_time="00" this%refresh_frequency="PT0S" this%refresh_offset="PT0S" - if (allocated(this%source_time)) then + if (allocated(this%source_time)) then deallocate(this%source_time,stat=status) _VERIFY(status) end if diff --git a/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 b/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 deleted file mode 100644 index 8a46e80933f2..000000000000 --- a/gridcomps/ExtData2G/ExtDataYamlNodeStack.F90 +++ /dev/null @@ -1,14 +0,0 @@ -module MAPL_ExtDataYamlNodeStack - use yaFyaml - use MAPL_ExtDataYamlNodeWrapper - implicit none - - public :: max_file_depth - public :: stack_depth - public :: yaml_node_stack - - integer, save :: stack_depth = 0 - integer, parameter :: MAX_FILE_DEPTH = 20 - type(YamlNodeWrapper), save :: yaml_node_stack(MAX_FILE_DEPTH) - -end module MAPL_ExtDataYamlNodeStack diff --git a/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 b/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 deleted file mode 100644 index 4e88b19047f1..000000000000 --- a/gridcomps/ExtData2G/ExtDataYamlNodeWrapper.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module MAPL_ExtDataYamlNodeWrapper - use yaFyaml - implicit none - - public YamlNodeWrapper - - type :: YamlNodeWrapper - class(YAML_Node), allocatable :: a_yaml_node - end type - -end module MAPL_ExtDataYamlNodeWrapper diff --git a/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 b/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 index 1e116ee47a8d..eda391c11d01 100644 --- a/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 +++ b/gridcomps/ExtData2G/ExtData_IOBundleMod.F90 @@ -10,6 +10,7 @@ module MAPL_ExtDataNG_IOBundleMod use ESMF use MAPL_BaseMod use MAPL_GriddedIOMod + use MAPL_TileIOMod use MAPL_ExceptionHandling use MAPL_GriddedIOItemMod use MAPL_GriddedIOItemVectorMod @@ -17,7 +18,8 @@ module MAPL_ExtDataNG_IOBundleMod public :: ExtDataNG_IOBundle type ExtDataNG_IOBundle - type (MAPL_GriddedIO) :: cfio + type (MAPL_GriddedIO) :: grid_io + type (MAPL_TileIO) :: tile_io type (ESMF_FieldBundle) :: pbundle character(:), allocatable :: template integer :: regrid_method @@ -30,11 +32,12 @@ module MAPL_ExtDataNG_IOBundleMod integer :: metadata_coll_id integer :: server_coll_id type(GriddedIOItemVector) :: items + logical :: on_tiles contains procedure :: clean - procedure :: make_cfio + procedure :: make_io procedure :: assign generic :: assignment(=) => assign end type ExtDataNG_IOBundle @@ -46,7 +49,7 @@ module MAPL_ExtDataNG_IOBundleMod contains - function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index, regrid_method, fraction, template, metadata_coll_id,server_coll_id,items,rc) result(io_bundle) + function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index, regrid_method, fraction, template, metadata_coll_id,server_coll_id,items, on_tiles, rc) result(io_bundle) type (ExtDataNG_IOBundle) :: io_bundle integer, intent(in) :: bracket_side @@ -59,6 +62,7 @@ function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index integer, intent(in) :: metadata_coll_id integer, intent(in) :: server_coll_id type(GriddedIOItemVector) :: items + logical, intent(in) :: on_tiles integer, optional, intent(out) :: rc io_bundle%bracket_side = bracket_side @@ -72,6 +76,7 @@ function new_ExtDataNG_IOBundle(bracket_side, entry_index, file_name, time_index io_bundle%metadata_coll_id=metadata_coll_id io_bundle%server_coll_id=server_coll_id io_bundle%items=items + io_bundle%on_tiles = on_tiles _RETURN(ESMF_SUCCESS) end function new_ExtDataNG_IOBundle @@ -90,18 +95,22 @@ subroutine clean(this, rc) end subroutine clean - subroutine make_cfio(this, rc) + subroutine make_io(this, rc) class (ExtDataNG_IOBundle), intent(inout) :: this integer, optional, intent(out) :: rc - this%cfio = MAPL_GriddedIO(output_bundle=this%pbundle,regrid_method=this%regrid_method, & - read_collection_id=this%server_coll_id, & - metadata_collection_id = this%metadata_coll_id, fraction = this%fraction, & - items=this%items) + if (this%on_tiles) then + this%tile_io = MAPL_TileIO(this%pbundle,this%server_coll_id) + else + this%grid_io = MAPL_GriddedIO(output_bundle=this%pbundle,regrid_method=this%regrid_method, & + read_collection_id=this%server_coll_id, & + metadata_collection_id = this%metadata_coll_id, fraction = this%fraction, & + items=this%items) + end if _RETURN(ESMF_SUCCESS) - end subroutine make_cfio + end subroutine make_io subroutine assign(to,from) class(ExtDataNG_IOBundle), intent(out) :: to @@ -119,7 +128,9 @@ subroutine assign(to,from) to%server_coll_id=from%server_coll_id to%items=from%items to%pbundle=from%pbundle - to%CFIO=from%CFIO + to%grid_io=from%grid_io + to%tile_io=from%tile_io + to%on_tiles=from%on_tiles end subroutine assign diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 0973f096f2dc..817da678dded 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -4,6 +4,7 @@ set (srcs MAPL_HistoryTrajectoryMod.F90 MAPL_HistoryCollection.F90 MAPL_HistoryGridComp.F90 + MAPL_StationSamplerMod.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 4793ef09a3e7..d6b3ca0815b0 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -9,6 +9,7 @@ module MAPL_HistoryCollectionMod use MAPL_VerticalDataMod use MAPL_TimeDataMod use HistoryTrajectoryMod + use StationSamplerMod use gFTL_StringStringMap implicit none @@ -100,12 +101,15 @@ module MAPL_HistoryCollectionMod character(len=ESMF_MAXSTR) :: output_grid_label type(GriddedIOItemVector) :: items character(len=ESMF_MAXSTR) :: currentFile - character(len=ESMF_MAXPATHLEN) :: trackFile + character(len=ESMF_MAXPATHLEN) :: obsFile + character(len=ESMF_MAXPATHLEN) :: stationIdFile logical :: splitField logical :: regex logical :: timeseries_output = .false. logical :: recycle_track = .false. type(HistoryTrajectory) :: trajectory + type(StationSampler) :: station_sampler + character(len=ESMF_MAXSTR) :: sampler_spec = "" character(len=ESMF_MAXSTR) :: positive type(HistoryCollectionGlobalAttributes) :: global_atts contains diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 973bbb2c8e75..a01c4bc22200 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -52,11 +52,13 @@ module MAPL_HistoryGridCompMod use MAPL_DownbitMod use pFIO_ConstantsMod use HistoryTrajectoryMod + use StationSamplerMod use MAPL_StringTemplate use regex_module use MAPL_TimeUtilsMod, only: is_valid_time, is_valid_date use gFTL_StringStringMap !use ESMF_CFIOMOD + use pflogger, only: Logger, logging implicit none private @@ -192,10 +194,10 @@ end subroutine SetServices ! Diagnostics have the following attributes: ! !1. Diagnostics may be `instantaneous` or `time-averaged` -!2. Diagnostics have a `frequency` and an associated `ref_date` and `ref_time` -! from which the frequency is based. An `end_date` and `end_time` may also be +!2. Diagnostics have a `frequency` and an associated `ref_date` and `ref_time` +! from which the frequency is based. An `end_date` and `end_time` may also be ! used to turn off diagnostics after a given date and time. -!3. Time-Averaged Diagnostics have an associated accumulation interval, +!3. Time-Averaged Diagnostics have an associated accumulation interval, ! `acc_interval`, which may be <= to the diagnostic `frequency` !4. Diagnostics are `time-stamped` with the center of the time-averaged period. !5. The default `acc_interval` is the diagnostic `frequency` @@ -207,7 +209,7 @@ end subroutine SetServices ! History Lists contain the following attributes: ! !- **filename**: Character string defining the filename of a particular diagnostic output stream. -!- **template**: Character string defining the time stamping template following GrADS convensions. +!- **template**: Character string defining the time stamping template following GrADS convensions. ! The default value depends on the duration of the file. !- **format**: Character string defining file format ("flat" or "CFIO"). Default = "flat". !- **mode**: Character string equal to "instantaneous" or "time-averaged". Default = "instantaneous". @@ -861,15 +863,19 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if end if if (has_regrid_keyword) then - call ESMF_ConfigGetAttribute ( cfg, regrid_method, default="REGRID_METHOD_BILINEAR", & - label=trim(string) // 'regrid_method:' ,_RC ) + call ESMF_ConfigGetAttribute ( cfg, regrid_method, label=trim(string) // 'regrid_method:' ,_RC ) list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if + call ESMF_ConfigGetAttribute(cfg, value=list(n)%sampler_spec, default="", & + label=trim(string) // 'sampler_spec:', _RC) + call ESMF_ConfigGetAttribute(cfg, value=list(n)%stationIdFile, default="", & + label=trim(string) // 'station_id_file:', _RC) + ! Get an optional file containing a 1-D track for the output - call ESMF_ConfigGetAttribute(cfg, value=list(n)%trackFile, default="", & + call ESMF_ConfigGetAttribute(cfg, value=list(n)%obsFile, default="", & label=trim(string) // 'track_file:', _RC) - if (trim(list(n)%trackfile) /= '') list(n)%timeseries_output = .true. + if (trim(list(n)%obsFile) /= '') list(n)%timeseries_output = .true. call ESMF_ConfigGetAttribute(cfg, value=list(n)%recycle_track, default=.false., & label=trim(string) // 'recycle_track:', _RC) @@ -2332,6 +2338,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) do n=1,nlist if (list(n)%disabled) cycle + string = trim( list(n)%collection ) // '.' + cfg = ESMF_ConfigCreate(_RC) + call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', _RC) if (list(n)%format == 'CFIOasync') then list(n)%format = 'CFIO' if (mapl_am_i_root()) write(*,*)'Chose CFIOasync setting to CFIO, update your History.rc file' @@ -2361,8 +2370,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then - list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),_RC) + list(n)%trajectory = HistoryTrajectory(cfg,string,_RC) call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) + + elseif (list(n)%sampler_spec == 'station') then + list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile),_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)/='') then @@ -2375,6 +2388,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) end if end if + call ESMF_ConfigDestroy(cfg, _RC) end do ! Echo History List Data Structure @@ -2426,6 +2440,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) print *, ' End_Date: ', list(n)%end_date print *, ' End_Time: ', list(n)%end_time endif + print *, ' Regrid Mthd: ', regrid_method_int_to_string(list(n)%regrid_method) block integer :: im_world, jm_world,dims(3) @@ -3201,6 +3216,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! ErrLog vars integer :: status logical :: file_exists + type(Logger), pointer :: lgr !============================================================================= @@ -3406,6 +3422,7 @@ subroutine Run ( gc, import, export, clock, rc ) end if endif + lgr => logging%get_logger('HISTORY.sampler') if (list(n)%timeseries_output) then if (list(n)%unit.eq.0) then if (mapl_am_i_root()) write(6,*)"Sampling to new file: ",trim(filename(n)) @@ -3415,6 +3432,15 @@ subroutine Run ( gc, import, export, clock, rc ) list(n)%unit = -1 end if list(n)%currentFile = filename(n) + elseif (list(n)%sampler_spec == 'station') then + if (list(n)%unit.eq.0) then + if (mapl_am_i_root()) call lgr%debug('%a %a',& + "Station_data output to new file:",trim(filename(n))) + call list(n)%station_sampler%close_file_handle(_RC) + call list(n)%station_sampler%create_file_handle(filename(n),_RC) + list(n)%currentFile = filename(n) + list(n)%unit = -1 + end if else if( list(n)%unit.eq.0 ) then if (list(n)%format == 'CFIO') then @@ -3561,6 +3587,10 @@ subroutine Run ( gc, import, export, clock, rc ) call ESMF_ClockGet(clock,currTime=current_time,_RC) call list(n)%trajectory%append_file(current_time,_RC) end if + if (list(n)%sampler_spec == 'station') then + call ESMF_ClockGet(clock,currTime=current_time,_RC) + call list(n)%station_sampler%append_file(current_time,_RC) + endif if( Writing(n) .and. list(n)%unit < 0) then @@ -3586,9 +3616,9 @@ subroutine Run ( gc, import, export, clock, rc ) end subroutine Run !====================================================== -!> +!> ! Finanlize the `MAPL_HistoryGridComp` component. -! +! subroutine Finalize ( gc, import, export, clock, rc ) type(ESMF_GridComp), intent(inout) :: gc !! composite gridded component @@ -5080,7 +5110,7 @@ subroutine CopyStateItems(src, dst, rc) call ESMF_StateGet(src, itemNames(n), bundle(1), _RC) call ESMF_StateAdd(dst, bundle, _RC) end if - end do + end do deallocate(itemTypes) deallocate(itemNames) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index dd63f711a17a..4ccbe9f5dac3 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -15,6 +15,8 @@ module HistoryTrajectoryMod use MAPL_VerticalDataMod use MAPL_BaseMod use MAPL_CommsMod + use MAPL_SortMod + use MAPL_NetCDF use MAPL_LocstreamRegridderMod use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 @@ -28,6 +30,7 @@ module HistoryTrajectoryMod type(ESMF_LocStream) :: root_locstream,dist_locstream type(LocStreamFactory) :: locstream_factory type(ESMF_Time), allocatable :: times(:) + real(kind=REAL64), allocatable :: times_R8(:) real(kind=REAL64), allocatable :: lons(:),lats(:) type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle @@ -43,6 +46,15 @@ module HistoryTrajectoryMod character(LEN=ESMF_MAXPATHLEN) :: file_name type(TimeData) :: time_info logical :: recycle_track + character(len=ESMF_MAXSTR) :: obsFile + 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) :: var_name_time + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: datetime_units contains procedure :: initialize procedure :: create_variable @@ -55,47 +67,102 @@ module HistoryTrajectoryMod procedure :: get_file_start_time procedure :: get procedure :: reset_times_to_current_day + procedure :: sort_arrays_by_time + procedure :: time_real_to_ESMF + end type interface HistoryTrajectory - module procedure HistoryTrajectory_from_file + module procedure HistoryTrajectory_from_config end interface HistoryTrajectory contains - function HistoryTrajectory_from_file(filename,unusable,rc) result(trajectory) - type(HistoryTrajectory) :: trajectory - character(len=*), intent(in) :: filename + function HistoryTrajectory_from_config(config,string,unusable,rc) result(traj) + use pflogger, only : Logger, logging + type(HistoryTrajectory) :: traj + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: status + character(len=ESMF_MAXSTR) :: filename type(NetCDF4_FileFormatter) :: formatter - type(FileMetadataUtils) :: metadata + type(FileMetadataUtils) :: metadata_utils type(FileMetadata) :: basic_metadata - integer :: num_times + integer(ESMF_KIND_I8) :: num_times + + integer :: ncid, grpid, ncid0 + integer :: dimid(10), dimlen(10) + integer :: len + integer :: i + character(len=ESMF_MAXSTR) :: grp_name + character(len=ESMF_MAXSTR) :: dim_name(10) + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_time + type(Logger), pointer :: lgr _UNUSED_DUMMY(unusable) + call ESMF_ConfigGetAttribute(config, value=traj%obsFile, default="", & + label=trim(string) // 'track_file:', _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) + + traj%datetime_units = "seconds since 1970-01-01 00:00:00" + + filename=trim(traj%obsFile) call formatter%open(trim(filename),pFIO_READ,_RC) - basic_metadata = formatter%read(_RC) - call metadata%create(basic_metadata,trim(filename)) - num_times = metadata%get_dimension("time",_RC) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) - if (metadata%is_var_present("longitude")) then - call formatter%get_var("longitude",trajectory%lons,_RC) - end if - if (metadata%is_var_present("latitude")) then - call formatter%get_var("latitude",trajectory%lats,_RC) - end if + if (traj%nc_index == '') then + basic_metadata = formatter%read(_RC) + call metadata_utils%create(basic_metadata,trim(filename)) + num_times = metadata_utils%get_dimension("time",_RC) + allocate(traj%lons(num_times),traj%lats(num_times),_STAT) + if (metadata_utils%is_var_present("longitude")) then + call formatter%get_var("longitude",traj%lons,_RC) + end if + if (metadata_utils%is_var_present("latitude")) then + call formatter%get_var("latitude",traj%lats,_RC) + end if + call metadata_utils%get_time_info(timeVector=traj%times,_RC) + else + i=index(traj%nc_longitude, '/') + _ASSERT (i>0, 'group name not found') + grp_name = traj%nc_longitude(1:i-1) + traj%var_name_lat = traj%nc_latitude(i+1:) + traj%var_name_lon = traj%nc_longitude(i+1:) + traj%var_name_time= traj%nc_time(i+1:) + + call formatter%open(trim(filename),pFIO_READ,_RC) + basic_metadata = formatter%read(_RC) + call metadata_utils%create(basic_metadata,trim(filename)) + num_times = basic_metadata%get_dimension(trim(traj%nc_index),_RC) + len = num_times + + allocate(traj%lons(len),traj%lats(len),_STAT) + allocate(traj%times_R8(len),traj%times(len),_STAT) + call formatter%get_var(traj%var_name_lon, traj%lons, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(traj%var_name_lat, traj%lats, group_name=grp_name, count=[len], rc=status) + call formatter%get_var(traj%var_name_time, traj%times_R8, group_name=grp_name, count=[len], rc=status) + + call traj%sort_arrays_by_time(_RC) + call traj%time_real_to_ESMF(_RC) + endif - call metadata%get_time_info(timeVector=trajectory%times,_RC) - trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,_RC) - trajectory%root_locstream = trajectory%locstream_factory%create_locstream(_RC) + traj%locstream_factory = LocStreamFactory(traj%lons,traj%lats,_RC) + traj%root_locstream = traj%locstream_factory%create_locstream(_RC) _RETURN(_SUCCESS) - end function HistoryTrajectory_from_file + end function HistoryTrajectory_from_config subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc) class(HistoryTrajectory), intent(inout) :: this @@ -563,4 +630,65 @@ subroutine reset_times_to_current_day(this,rc) end subroutine reset_times_to_current_day + + subroutine sort_arrays_by_time(this,rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + + integer :: i, len + integer, allocatable :: IA(:) + real(ESMF_KIND_R8), allocatable :: X(:), Y(:) + integer(ESMF_KIND_I8), allocatable :: IX(:) + + len = size (this%times_R8) + allocate (IA(len), IX(len), X(len)) + do i=1, len + IX(i)=this%times_R8(i) + IA(i)=i + enddo + call MAPL_Sort(IX,IA) + + X = this%lons + do i=1, len + this%lons(i) = X(IA(i)) + enddo + X = this%lats + do i=1, len + this%lats(i) = X(IA(i)) + enddo + X = this%times_R8 + do i=1, len + this%times_R8(i) = X(IA(i)) + enddo + + _RETURN(_SUCCESS) + end subroutine sort_arrays_by_time + + + subroutine time_real_to_ESMF (this,rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + + integer :: i, len + integer :: int_time + type(ESMF_TimeInterval) :: interval + type(ESMF_Time) :: time0 + type(ESMF_Time) :: time1 + character(len=:), allocatable :: tunit + character(len=ESMF_MAXSTR) :: datetime_units + + datetime_units = this%datetime_units + len = size (this%times_R8) + + do i=1, len + int_time = this%times_R8(i) + call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, time0, time1=time1, tunit=tunit, _RC) + this%times(i) = time1 + enddo + + _RETURN(_SUCCESS) + end subroutine time_real_to_ESMF + end module HistoryTrajectoryMod diff --git a/gridcomps/History/MAPL_StationSamplerMod.F90 b/gridcomps/History/MAPL_StationSamplerMod.F90 new file mode 100644 index 000000000000..0c56b7e7692e --- /dev/null +++ b/gridcomps/History/MAPL_StationSamplerMod.F90 @@ -0,0 +1,522 @@ +#include "MAPL_Generic.h" +module StationSamplerMod + use ESMF + use MAPL_ErrorHandlingMod + use LocStreamFactoryMod + use pFIO + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_LocstreamRegridderMod + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_c_binding, only: C_NULL_CHAR + implicit none + private + + public :: StationSampler + type :: StationSampler + private + type(LocStreamFactory) :: LSF + type(ESMF_LocStream) :: esmf_ls + type(LocstreamRegridder) :: regridder + integer :: nstation + integer, allocatable :: station_id(:) + character(len=ESMF_MAXSTR), allocatable :: station_name(:) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + real(kind=REAL64), allocatable :: elevs(:) + type(ESMF_FieldBundle) :: bundle + type(FileMetadata) :: fmd + type(NetCDF4_FileFormatter) :: formatter + type(VerticalData) :: vdata + type(TimeData) :: time_info + character(LEN=ESMF_MAXPATHLEN) :: ofile + integer :: obs_written + contains + procedure :: add_metadata_route_handle + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file + procedure :: get_file_start_time + procedure :: compute_time_for_current + end type StationSampler + + interface StationSampler + module procedure new_StationSampler_readfile + end interface StationSampler + +contains + + function new_StationSampler_readfile (filename,rc) result(sampler) + use pflogger, only : Logger, logging + implicit none + type(StationSampler) :: sampler + character(len=*), intent(in) :: filename + integer, optional, intent(out) :: rc + + character(len=40) :: str, sdmy, shms + integer :: unit, ios, nstation, status + integer :: i, j, id, ncount + real :: x, y, z + logical :: con1, con2 + character (len=1) :: CH1 + character (len=5) :: seq + character (len=100) :: line + type(Logger), pointer :: lgr + + !__ 1. read from station_id_file: static + ! plain text format: + ! [name,lat,lon,elev] or [id,name,lat,lon,elev] + ! + open(newunit=unit, file=trim(filename), form='formatted', & + access='sequential', status='old', _IOSTAT) + ios=0 + nstation=0 + read(unit, '(a100)', IOSTAT=ios) line + call count_substring(line, ',', ncount) + con1= ncount.GE.3 .AND. ncount.LE.4 + _ASSERT(con1, 'string sequence in Aeronet file not supported') + if (ncount==3) then + seq='AFFF' + elseif (ncount==4) then + CH1=line(1:1) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + con2= CH1>='0'.AND.CH1<='9' + if (con1) then + seq='AIFFF' + else + if (con2) then + seq='IAFFF' + else + _ASSERT(.false., 'string sequence in Aeronet file not supported') + end if + end if + end if + + rewind(unit) + ios=0 + do while (ios==0) + read(unit, '(a100)', IOSTAT=ios) line + if (ios==0) nstation=nstation+1 + end do + sampler%nstation=nstation + allocate(sampler%station_id(nstation)) + allocate(sampler%station_name(nstation)) + allocate(sampler%lons(nstation)) + allocate(sampler%lats(nstation)) + allocate(sampler%elevs(nstation)) + rewind(unit) + do i=1, nstation + if(seq=='IAFFF') then + read(unit, *) & + sampler%station_id(i), & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + elseif(seq=='AIFFF') then + read(unit, *) & + sampler%station_name(i), & + sampler%station_id(i), & + sampler%lats(i), & + sampler%lons(i) + elseif(trim(seq)=='AFFF') then + read(unit, *) & + sampler%station_name(i), & + sampler%lats(i), & + sampler%lons(i) + sampler%station_id(i)=i + end if + end do + close(unit) + lgr => logging%get_logger('HISTORY.sampler') + call lgr%debug('%a %i8', 'nstation=', nstation) + call lgr%debug('%a %a %a', 'sampler%station_name(1:2) : ', & + trim(sampler%station_name(1)), trim(sampler%station_name(2))) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& + sampler%lons(1),sampler%lons(2)) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lats(1:2) : ',& + sampler%lats(1),sampler%lats(2)) + + !__ 2. create LocStreamFactory, then esmf_ls including route_handle + ! + sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) + sampler%esmf_ls = sampler%LSF%create_locstream(_RC) + ! + ! init ofile + sampler%ofile='' + sampler%obs_written=0 + + _RETURN(_SUCCESS) + end function new_StationSampler_readfile + + subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_FieldBundle), intent(in) :: bundle + type(TimeData), intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + integer, optional, intent(out) :: rc + + type(variable) :: v + type(ESMF_Grid) :: grid + type(ESMF_Clock) :: clock + type(ESMF_Field) :: field + integer :: fieldCount + integer :: fieldCount_max = 1000 + integer :: field_rank + integer :: nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM) + integer :: lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + integer :: status + integer :: i + + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims + + !__ 1. metadata add_dimension, + ! add_variable for time, latlon, station + ! + this%bundle = bundle + nstation = this%nstation + if (present(vdata)) then + this%vdata = vdata + else + this%vdata = VerticalData(_RC) + end if + call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! specify lev in fmd + do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then + call this%vdata%get_interpolating_variable(this%bundle,_RC) + endif + + call timeInfo%add_time_to_metadata(this%fmd,_RC) ! specify time in fmd + this%time_info = timeInfo + + call this%fmd%add_dimension('station_index',nstation) + + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','longitude') + call v%add_attribute('unit','degree_east') + call this%fmd%add_variable('longitude',v) + + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','latitude') + call v%add_attribute('unit','degree_north') + call this%fmd%add_variable('latitude',v) + + v = Variable(type=pFIO_INT32, dimensions='station_index') + call this%fmd%add_variable('station_id',v) + + !__ 2. filemetadata: extract field from bundle, add_variable + ! + call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + var_name=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(bundle,var_name,field=field,_RC) + call ESMF_FieldGet(field,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = "station_index,time" + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[nstation,1]) + else if (field_rank==3) then + vdims = "lev,station_index,time" + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + end if + call v%add_attribute('units', trim(units)) + call v%add_attribute('long_name', trim(long_name)) + call v%add_attribute('missing_value', MAPL_UNDEF) + call v%add_attribute('_FillValue', MAPL_UNDEF) + call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%fmd%add_variable(trim(var_name),v,_RC) + end do + deallocate (fieldNameList) + + !__ 3. locstream route handle + ! + call ESMF_FieldBundleGet(bundle,grid=grid,_RC) + this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) + + _RETURN(_SUCCESS) + end subroutine add_metadata_route_handle + + subroutine append_file(this,current_time,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + ! + integer :: status + integer :: fieldCount + integer :: ub(1), lb(1) + type(ESMF_Field) :: src_field,dst_field + real(kind=REAL32), allocatable :: p_new_lev(:,:,:) + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + real(kind=REAL32), allocatable :: arr(:,:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: xname + real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i, id, iobs, ix, rank + integer :: nx, nz + + this%obs_written=this%obs_written+1 + + !__ 1. put_var: time variable + ! + rtimes = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%setup_eta_to_pressure(_RC) + end if + if (mapl_am_i_root()) then + call this%formatter%put_var('time',rtimes(1:1),& + start=[this%obs_written],count=[1],_RC) + end if + + !__ 2. put_var: ungridded_dim from src to dst [regrid] + ! + call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + xname=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(this%bundle,xname,field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname, & + typekind=ESMF_TYPEKIND_R4,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) + if (mapl_am_i_root()) then + call this%formatter%put_var(xname,p_dst_2d,& + start=[1,this%obs_written],count=[this%nstation,1],_RC) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + if (this%vdata%lm/=(ub(1)-lb(1)+1)) then + lb(1)=1 + ub(1)=this%vdata%lm + end if + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname,& + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) + if (mapl_am_i_root()) then + nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx)) + arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) + call this%formatter%put_var(xname,arr,& + start=[1,1,this%obs_written],count=[nz,nx,1],_RC) + !note: lev,station,time + deallocate(arr) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else + _FAIL('grid2LS regridder: rank > 3 not implemented') + end if + end do + deallocate (fieldNameList) + _RETURN(_SUCCESS) + end subroutine append_file + + + subroutine create_file_handle(this,filename,rc) + class(StationSampler), intent(inout) :: this + character(len=*), intent(inout) :: filename ! for ouput nc + integer, optional, intent(out) :: rc + type(variable) :: v + integer :: status + + this%ofile = trim(filename) + v = this%time_info%define_time_variable(_RC) + call this%fmd%modify_variable('time',v,_RC) + this%obs_written = 0 + + if (.not. mapl_am_I_root()) then + _RETURN(_SUCCESS) + end if + call this%formatter%create(trim(filename),_RC) + call this%formatter%write(this%fmd,_RC) + call this%formatter%put_var('longitude',this%lons,_RC) + call this%formatter%put_var('latitude',this%lats,_RC) + call this%formatter%put_var('station_id',this%station_id,_RC) + + _RETURN(_SUCCESS) + end subroutine create_file_handle + + + subroutine close_file_handle(this,rc) + class(StationSampler), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + if (trim(this%ofile) /= '') then + if (mapl_am_i_root()) then + call this%formatter%close(_RC) + end if + end if + _RETURN(_SUCCESS) + end subroutine close_file_handle + + + function compute_time_for_current(this,current_time,rc) result(rtimes) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i,status + type(ESMF_TimeInterval) :: tint + type(ESMF_Time) :: file_start_time + character(len=ESMF_MAXSTR) :: tunit + + allocate(rtimes(1),_STAT) + call this%get_file_start_time(file_start_time,tunit,_RC) + tint = current_time-file_start_time + select case(trim(tunit)) + case ('days') + call ESMF_TimeIntervalGet(tint,d_r8=rtimes(1),_RC) + case ('hours') + call ESMF_TimeIntervalGet(tint,h_r8=rtimes(1),_RC) + case ('minutes') + call ESMF_TimeIntervalGet(tint,m_r8=rtimes(1),_RC) + case default + _FAIL('illegal value for tunit: '//trim(tunit)) + end select + _RETURN(_SUCCESS) + end function compute_time_for_current + + + !-- a subroutine from MAPL_HistoryTrajectoryMod.F90 + ! TODO: consolidate with trajectory + subroutine get_file_start_time(this,start_time,time_units,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(inout) :: start_time + character(len=*), intent(inout) :: time_units + integer, optional, intent(out) :: rc + + integer :: status + class(Variable), pointer :: var + type(Attribute), pointer :: attr + class(*), pointer :: pTimeUnits + character(len=ESMF_MAXSTR) :: timeUnits + + integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) + integer strlen + integer firstdash, lastdash + integer firstcolon, lastcolon + integer lastspace,since_pos + integer year,month,day,hour,min,sec + + var => this%fmd%get_variable('time',_RC) + attr => var%get_attribute('units') + ptimeUnits => attr%get_value() + select type(pTimeUnits) + type is (character(*)) + timeUnits = pTimeUnits + strlen = LEN_TRIM (TimeUnits) + + since_pos = index(TimeUnits, 'since') + time_units = trim(TimeUnits(:since_pos-1)) + time_units = trim(time_units) + + firstdash = index(TimeUnits, '-') + lastdash = index(TimeUnits, '-', BACK=.TRUE.) + + if (firstdash .LE. 0 .OR. lastdash .LE. 0) then + if (present(rc)) rc = -1 + return + endif + ypos(2) = firstdash - 1 + mpos(1) = firstdash + 1 + ypos(1) = ypos(2) - 3 + + mpos(2) = lastdash - 1 + dpos(1) = lastdash + 1 + dpos(2) = dpos(1) + 1 + + read ( TimeUnits(ypos(1):ypos(2)), * ) year + read ( TimeUnits(mpos(1):mpos(2)), * ) month + read ( TimeUnits(dpos(1):dpos(2)), * ) day + + firstcolon = index(TimeUnits, ':') + if (firstcolon .LE. 0) then + ! If no colons, check for hour. + ! Logic below assumes a null character or something else is after the hour + ! if we do not find a null character add one so that it correctly parses time + if (TimeUnits(strlen:strlen) /= C_NULL_CHAR) then + TimeUnits = trim(TimeUnits)//C_NULL_CHAR + strlen=len_trim(TimeUnits) + endif + lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) + if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then + hpos(1) = lastspace+1 + hpos(2) = strlen-1 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + min = 0 + sec = 0 + else + hour = 0 + min = 0 + sec = 0 + endif + else + hpos(1) = firstcolon - 2 + hpos(2) = firstcolon - 1 + lastcolon = index(TimeUnits, ':', BACK=.TRUE.) + if ( lastcolon .EQ. firstcolon ) then + mpos(1) = firstcolon + 1 + mpos(2) = firstcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + sec = 0 + else + mpos(1) = firstcolon + 1 + mpos(2) = lastcolon - 1 + spos(1) = lastcolon + 1 + spos(2) = lastcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + read (TimeUnits(spos(1):spos(2)), * ) sec + endif + endif + class default + _FAIL("Time unit must be character") + end select + call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) + _RETURN(_SUCCESS) + end subroutine get_file_start_time + + ! TODO: delete and use system utilities when available + Subroutine count_substring (str, t, ncount) + character (len=*), intent(in) :: str + character (len=*), intent(in) :: t + integer, intent(out) :: ncount + integer :: i, j, k, lt + ncount=0 + k=1 + lt = len(t) - 1 + do + i=index(str(k:), t) + if (i==0) exit + ncount = ncount + 1 + k=k+i+lt + end do + end subroutine count_substring + +end module StationSamplerMod diff --git a/griddedio/CMakeLists.txt b/griddedio/CMakeLists.txt index a34c6fdab1c0..1721226ab822 100644 --- a/griddedio/CMakeLists.txt +++ b/griddedio/CMakeLists.txt @@ -7,6 +7,7 @@ set (srcs GriddedIO.F90 FieldBundleRead.F90 FieldBundleWrite.F90 + TileIO.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.pfio diff --git a/griddedio/DataCollection.F90 b/griddedio/DataCollection.F90 index 9dd092e7ad10..c881a4f8bd04 100644 --- a/griddedio/DataCollection.F90 +++ b/griddedio/DataCollection.F90 @@ -61,6 +61,9 @@ function find(this, file_name, rc) result(metadata) type (StringIntegerMapIterator) :: iter class (AbstractGridFactory), allocatable :: factory integer :: status + type(StringIntegerMap), pointer :: dimensions + integer, pointer :: tile_size + logical :: skip_grid file_id => this%file_ids%at(file_name) @@ -103,7 +106,11 @@ function find(this, file_name, rc) result(metadata) call this%metadatas%push_back(metadata) deallocate(metadata) metadata => this%metadatas%back() - if (.not. allocated(this%src_grid)) then + dimensions => metadata%get_dimensions() + tile_size => dimensions%at("tile_index") + skip_grid = associated(tile_size) + + if ( (.not. allocated(this%src_grid)) .and. (.not. skip_grid)) then allocate(factory, source=grid_manager%make_factory(trim(file_name),force_file_coordinates=this%use_file_coords)) this%src_grid = grid_manager%make_grid(factory) end if diff --git a/griddedio/TileIO.F90 b/griddedio/TileIO.F90 new file mode 100644 index 000000000000..7b55aca9609c --- /dev/null +++ b/griddedio/TileIO.F90 @@ -0,0 +1,121 @@ +#include "MAPL_Generic.h" + +module MAPL_TileIOMod + use ESMF + use pFIO + use MAPL_BaseMod + use MAPL_ExceptionHandling + use MAPL_CommsMod + use FIleIOSharedMod, only: MAPL_TileMaskGet + + implicit none + + private + + type, public :: MAPL_TileIO + private + type(ESMF_FieldBundle) :: bundle + integer :: read_collection_id + type(tile_buffer), allocatable :: tile_buffer(:) + contains + procedure :: request_data_from_file + 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 + + contains + + function new_MAPL_TileIO(bundle,read_collection_id) result(TileIO) + type(MAPL_TileIO) :: TileIO + type(ESMF_FieldBundle),intent(in) :: bundle + integer, intent(in) :: read_collection_id + + 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 + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Field) :: field + type(ESMF_Grid) :: grid + integer :: counts(3) + integer, allocatable :: local_start(:), global_start(:), global_count(:) + + + call ESMF_FieldBundleGet(this%bundle, fieldCount=num_vars, _RC) + allocate(this%tile_buffer(num_vars)) + allocate(names(num_vars)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=names, _RC) + do i=1,num_vars + call ESMF_FieldBundleGet(this%bundle,names(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,grid=grid,_RC) + call MAPL_GridGet(grid,globalCellCountPerDim=counts,_RC) + if (rank==1) then + allocate(local_start(2),global_start(2),global_count(2)) + local_start = [1,timeindex] + global_start = [1,timeindex] + global_count = [counts(1),1] + if (mapl_am_I_root()) then + allocate(this%tile_buffer(i)%ptr(counts(1)),_STAT) + else + 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, & + start=local_start, global_start=global_start, global_count = global_count) + deallocate(local_start,global_start,global_count) + else + _FAIL("rank >1 tile fields not supported") + end if + end do + + _RETURN(_SUCCESS) + end subroutine + + subroutine process_data_from_file(this,rc) + class(MAPL_TileIO), intent(inout) :: this + integer, intent(out), optional :: rc + + integer :: status + integer :: i,num_vars,rank + type(ESMF_Field) :: field + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Grid) :: grid + integer, pointer :: mask(:) + real, pointer :: ptr1d(:) + + call ESMF_FieldBundleGet(this%bundle, fieldCount=num_vars, _RC) + allocate(names(num_vars)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=names, _RC) + do i=1,num_vars + call ESMF_FieldBundleGet(this%bundle,names(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,grid=grid,_RC) + call MAPL_TileMaskGet(grid,mask,_RC) + if (rank==1) then + call ESMF_FieldGet(field,localDE=0,farrayPtr=ptr1d,_RC) + call ArrayScatter(ptr1d,this%tile_buffer(i)%ptr,grid,mask=mask,_RC) + deallocate(this%tile_buffer(i)%ptr) + else + _FAIL("rank not supported for tile io") + end if + enddo + deallocate(this%tile_buffer) + _RETURN(_SUCCESS) + end subroutine + +end module diff --git a/pfio/AbstractMessage.F90 b/pfio/AbstractMessage.F90 index 8927c3f0552e..44fc56d6ccd4 100644 --- a/pfio/AbstractMessage.F90 +++ b/pfio/AbstractMessage.F90 @@ -23,6 +23,7 @@ module pFIO_AbstractMessageMod public :: COLLECTIVEPrefetchData_ID public :: COLLECTIVEStageData_ID public :: ModifyMetadata_ID + public :: ReplaceMetadata_ID public :: HandShake_ID public :: DUMMY_ID public :: ForwardData_ID @@ -42,6 +43,7 @@ module pFIO_AbstractMessageMod enumerator :: StageData_ID enumerator :: COLLECTIVEStageData_ID enumerator :: ModifyMetadata_ID + enumerator :: ReplaceMetadata_ID enumerator :: HandShake_ID enumerator :: DUMMY_ID enumerator :: ForwardData_ID diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 9bb4fbac29fa..7de858a3edc6 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -46,6 +46,7 @@ set (srcs CollectiveStageDataMessage.F90 AddHistCollectionMessage.F90 ModifyMetadataMessage.F90 + ReplaceMetadataMessage.F90 ForwardDataAndMessage.F90 ForwardDataMessage.F90 ProtocolParser.F90 @@ -177,6 +178,6 @@ endif () # Unit testing -if (PFUNIT_FOUND) - add_subdirectory(tests EXCLUDE_FROM_ALL) -endif () +#if (PFUNIT_FOUND) + #add_subdirectory(tests EXCLUDE_FROM_ALL) +#endif () diff --git a/pfio/ClientManager.F90 b/pfio/ClientManager.F90 index fc19ebadb6b6..a572d8443c3a 100644 --- a/pfio/ClientManager.F90 +++ b/pfio/ClientManager.F90 @@ -39,7 +39,9 @@ module pFIO_ClientManagerMod procedure :: add_ext_collection procedure :: add_hist_collection procedure :: modify_metadata + procedure :: replace_metadata procedure :: modify_metadata_all + procedure :: replace_metadata_all procedure :: prefetch_data procedure :: stage_data procedure :: collective_prefetch_data @@ -187,6 +189,22 @@ subroutine modify_metadata(this, collection_id, unusable,var_map, rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata + subroutine replace_metadata(this, collection_id, fmd, rc) + class (ClientManager), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (ClientThread), pointer :: clientPtr + integer :: status + + ClientPtr => this%current() + call clientPtr%replace_metadata(collection_id, fmd, rc=status) + _VERIFY(status) + + _RETURN(_SUCCESS) + end subroutine replace_metadata + subroutine modify_metadata_all(this, collection_id, unusable,var_map,rc) class (ClientManager), intent(inout) :: this integer, intent(in) :: collection_id @@ -207,6 +225,24 @@ subroutine modify_metadata_all(this, collection_id, unusable,var_map,rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata_all + subroutine replace_metadata_all(this, collection_id, fmd, rc) + class (ClientManager), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (ClientThread), pointer :: clientPtr + integer :: i, status + + do i = 1, this%clients%size() + ClientPtr => this%clients%at(i) + call clientPtr%replace_metadata(collection_id, fmd, rc=status) + _VERIFY(status) + enddo + + _RETURN(_SUCCESS) + end subroutine replace_metadata_all + subroutine collective_prefetch_data(this, collection_id, file_name, var_name, data_reference, & & unusable, start,global_start,global_count, rc) class (ClientManager), intent(inout) :: this diff --git a/pfio/ClientThread.F90 b/pfio/ClientThread.F90 index 0a302bb552e1..f8e3c0491c6b 100644 --- a/pfio/ClientThread.F90 +++ b/pfio/ClientThread.F90 @@ -30,6 +30,7 @@ module pFIO_ClientThreadMod use pFIO_CollectivePrefetchDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_StringVariableMapMod use, intrinsic :: iso_fortran_env, only: REAL32 @@ -57,6 +58,7 @@ module pFIO_ClientThreadMod procedure :: add_ext_collection procedure :: add_hist_collection procedure :: modify_metadata + procedure :: replace_metadata procedure :: prefetch_data procedure :: stage_data procedure :: collective_prefetch_data @@ -209,6 +211,24 @@ subroutine modify_metadata(this, collection_id, unusable,var_map, rc) _UNUSED_DUMMY(unusable) end subroutine modify_metadata + subroutine replace_metadata(this, collection_id, fmd, rc) + class (ClientThread), intent(inout) :: this + integer, intent(in) :: collection_id + type (FileMetadata),intent(in) :: fmd + integer, optional, intent(out) :: rc + + class (AbstractMessage), pointer :: handshake_msg + class(AbstractSocket),pointer :: connection + integer :: status + + connection=>this%get_connection() + call connection%send(ReplaceMetadataMessage(collection_id,fmd),_RC) + + handshake_msg => connection%receive() + deallocate(handshake_msg) + _RETURN(_SUCCESS) + end subroutine replace_metadata + function collective_prefetch_data(this, collection_id, file_name, var_name, data_reference, & & unusable, start,global_start,global_count, rc) result(request_id) class (ClientThread), intent(inout) :: this diff --git a/pfio/HistoryCollection.F90 b/pfio/HistoryCollection.F90 index d42143112ca0..22ea616b274b 100644 --- a/pfio/HistoryCollection.F90 +++ b/pfio/HistoryCollection.F90 @@ -22,6 +22,7 @@ module pFIO_HistoryCollectionMod contains procedure :: find procedure :: ModifyMetadata + procedure :: ReplaceMetadata procedure :: clear end type HistoryCollection @@ -90,6 +91,19 @@ subroutine ModifyMetadata(this,var_map,rc) _RETURN(_SUCCESS) end subroutine ModifyMetadata + subroutine ReplaceMetadata(this, fmd,rc) + class (HistoryCollection), intent(inout) :: this + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + integer :: status + character(len=*), parameter :: Iam = "HistoryCollection::ReplaceMetadata()" + + this%fmd = fmd + + _RETURN(_SUCCESS) + end subroutine ReplaceMetadata + subroutine clear(this, rc) class (HistoryCollection), intent(inout) :: this integer, optional, intent(out) :: rc diff --git a/pfio/MessageVisitor.F90 b/pfio/MessageVisitor.F90 index e2134c940693..a61123adc191 100644 --- a/pfio/MessageVisitor.F90 +++ b/pfio/MessageVisitor.F90 @@ -20,6 +20,7 @@ module pFIO_MessageVisitorMod use pFIO_DummyMessageMod use pFIO_HandShakeMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_AbstractRequestHandleMod implicit none private @@ -45,6 +46,7 @@ module pFIO_MessageVisitorMod procedure :: handle_CollectiveStageData procedure :: handle_Terminate procedure :: handle_ModifyMetadata + procedure :: handle_ReplaceMetadata procedure :: handle_HandShake generic :: handle_cmd => handle_Done @@ -61,6 +63,7 @@ module pFIO_MessageVisitorMod generic :: handle_cmd => handle_CollectiveStageData generic :: handle_cmd => handle_Terminate generic :: handle_cmd => handle_ModifyMetadata + generic :: handle_cmd => handle_ReplaceMetadata generic :: handle_cmd => handle_HandShake end type MessageVisitor @@ -116,6 +119,9 @@ recursive subroutine handle(this, message, rc) type is (ModifyMetadataMessage) call this%handle_cmd(cmd,rc=status) _VERIFY(status) + type is (ReplaceMetadataMessage) + call this%handle_cmd(cmd,rc=status) + _VERIFY(status) type is (HandShakeMessage) ! the handShake is from client to server call this%handle_cmd(cmd, rc=status) @@ -257,6 +263,15 @@ subroutine handle_ModifyMetadata(this, message, rc) _UNUSED_DUMMY(message) end subroutine handle_ModifyMetadata + subroutine handle_ReplaceMetadata(this, message, rc) + class (MessageVisitor), intent(inout) :: this + type (ReplaceMetadataMessage), intent(in) :: message + integer, optional, intent(out) :: rc + _FAIL( "Warning : dummy handle_ReplaceMetadata should not be called") + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(message) + end subroutine handle_ReplaceMetadata + subroutine handle_HandShake(this, message, rc) class (MessageVisitor), target, intent(inout) :: this type (HandShakeMessage), intent(in) :: message diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index bc2220dccaf0..45fd8d5722b4 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -46,7 +46,7 @@ module pFIO_MultiGroupServerMod use pFIO_AbstractRequestHandleMod use pFIO_FileMetadataMod use pFIO_IntegerMessageMapMod - use gFTL2_StringSet, StringSetIterator =>SetIterator + use gFTL2_StringSet use mpi use pFlogger, only: logging, Logger @@ -560,9 +560,9 @@ subroutine dispatch_work(collection_id, idleRank, num_idlePEs, FileName, rc) enddo ! if there is no idle processor, get back to probe if (all(num_idlePEs == 0)) cycle - ! if this file is still being written, get back to probe + ! if this file is still being written, get back to probe iter = FilesBeingWritten%find(FileName) - if (iter /= FilesBeingWritten%end()) cycle + if (iter /= FilesBeingWritten%end()) cycle ! get the node with the most idle processors node_rank = maxloc(num_idlePEs, dim=1) - 1 diff --git a/pfio/ProtocolParser.F90 b/pfio/ProtocolParser.F90 index 30ff805329be..10946bc1af62 100644 --- a/pfio/ProtocolParser.F90 +++ b/pfio/ProtocolParser.F90 @@ -18,6 +18,7 @@ module pFIO_ProtocolParserMod use pFIO_CollectivePrefetchDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_HandShakeMessageMod use pFIO_DummyMessageMod use pFIO_ForwardDataMessageMod @@ -68,6 +69,7 @@ subroutine initialize(this) type (CollectivePrefetchDataMessage) :: CollectivePrefetchData type (CollectiveStageDataMessage) :: CollectiveStageData type (ModifyMetadataMessage) :: ModifyMetadata + type (ReplaceMetadataMessage) :: ReplaceMetadata type (HandShakeMessage) :: handshake type (DummyMessage) :: dummy type (ForwardDataMessage) :: ForwardData @@ -90,6 +92,8 @@ subroutine initialize(this) call add_prototype(CollectiveStageData) ModifyMetaData = ModifyMetadataMessage(collection_id=-1) call add_prototype(ModifyMetadata) + ReplaceMetaData = ReplaceMetadataMessage(-1, FileMetadata()) + call add_prototype(ReplaceMetadata) call add_prototype(handshake) call add_prototype(dummy) call add_prototype(ForwardData) diff --git a/pfio/ReplaceMetadataMessage.F90 b/pfio/ReplaceMetadataMessage.F90 new file mode 100644 index 000000000000..4c6f4e07c86e --- /dev/null +++ b/pfio/ReplaceMetadataMessage.F90 @@ -0,0 +1,95 @@ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +module pFIO_ReplaceMetadataMessageMod + use MAPL_ExceptionHandling + use pFIO_UtilitiesMod + use pFIO_FileMetadataMod + use pFIO_AbstractMessageMod + use pFIO_StringVariableMapMod + use pFIO_StringVariableMapUtilMod + use mapl_KeywordEnforcerMod + implicit none + private + + public :: ReplaceMetadataMessage + + type, extends(AbstractMessage) :: ReplaceMetadataMessage + integer :: collection_id + type (FileMetadata) :: fmd + contains + procedure, nopass :: get_type_id + procedure :: get_length + procedure :: serialize + procedure :: deserialize + end type ReplaceMetadataMessage + + interface ReplaceMetadataMessage + module procedure new_ReplaceMetadataMessage + end interface + +contains + + function new_ReplaceMetadataMessage(collection_id, fmd, rc) result (message) + type (ReplaceMetadataMessage) :: message + integer, intent(in) :: collection_id + type (FileMetadata), intent(in) :: fmd + integer, optional, intent(out) :: rc + + message%collection_id = collection_id + message%fmd = fmd + + _RETURN(_SUCCESS) + end function new_ReplaceMetadataMessage + + integer function get_type_id() result(type_id) + type_id = ReplaceMetadata_ID + end function get_type_id + + integer function get_length(this) result(length) + class (ReplaceMetadataMessage), intent(in) :: this + integer, allocatable :: buffer(:) + + allocate(buffer(0)) + + call this%fmd%serialize(buffer) + + length = & + & serialize_buffer_length(this%collection_id) + & + & size(buffer) + + end function get_length + + subroutine serialize(this, buffer, rc) + class (ReplaceMetadataMessage), intent(in) :: this + integer, intent(inout) :: buffer(:) + integer, optional, intent(out) :: rc + + integer, allocatable :: fmd_buf(:) + integer :: status + + call this%fmd%serialize(fmd_buf, rc=status) + _VERIFY(status) + buffer = [ & + & serialize_intrinsic(this%collection_id), & + & fmd_buf] + _RETURN(_SUCCESS) + end subroutine serialize + + subroutine deserialize(this, buffer, rc) + class (ReplaceMetadataMessage), intent(inout) :: this + integer, intent(in) :: buffer(:) + integer, optional, intent(out) :: rc + + integer :: n, status + + n = 1 + call deserialize_intrinsic(buffer(n:), this%collection_id) + n = n + serialize_buffer_length(this%collection_id) + + call FileMetadata_deserialize(buffer(n:), this%fmd, rc=status) + _VERIFY(status) + _RETURN(_SUCCESS) + end subroutine deserialize + +end module pFIO_ReplaceMetadataMessageMod diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index caa471eecf58..58a3aa5f2b58 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -41,6 +41,7 @@ module pFIO_ServerThreadMod use pFIO_StageDataMessageMod use pFIO_CollectiveStageDataMessageMod use pFIO_ModifyMetadataMessageMod + use pFIO_ReplaceMetadataMessageMod use pFIO_NetCDF4_FileFormatterMod use pFIO_HistoryCollectionMod @@ -95,6 +96,7 @@ module pFIO_ServerThreadMod procedure :: handle_StageData procedure :: handle_CollectiveStageData procedure :: handle_ModifyMetadata + procedure :: handle_ReplaceMetadata procedure :: handle_HandShake procedure :: get_hist_collection @@ -593,6 +595,25 @@ subroutine handle_ModifyMetadata(this, message, rc) _RETURN(_SUCCESS) end subroutine handle_ModifyMetadata + subroutine handle_ReplaceMetadata(this, message, rc) + class (ServerThread), intent(inout) :: this + type (ReplaceMetadataMessage), intent(in) :: message + integer, optional, intent(out) :: rc + + type (HistoryCollection),pointer :: hist_collection + class(AbstractSocket),pointer :: connection + type (DummyMessage) :: handshake_msg + integer :: status + + hist_collection=>this%hist_collections%at(message%collection_id) + call hist_collection%ReplaceMetadata(message%fmd) + + connection=>this%get_connection() + call connection%send(handshake_msg,_RC) + + _RETURN(_SUCCESS) + end subroutine handle_ReplaceMetadata + subroutine handle_HandShake(this, message, rc) class (ServerThread), target, intent(inout) :: this type (HandShakeMessage), intent(in) :: message diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 620e1553e64a..46389b996a12 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -28,6 +28,7 @@ set (srcs MAPL_DateTime_Parsing.F90 DownBit.F90 ShaveMantissa.c + MAPL_Sleep.F90 # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 diff --git a/shared/MAPL_Sleep.F90 b/shared/MAPL_Sleep.F90 new file mode 100644 index 000000000000..ca77c8412a72 --- /dev/null +++ b/shared/MAPL_Sleep.F90 @@ -0,0 +1,31 @@ +module MAPL_SleepMod + +use, intrinsic :: iso_fortran_env, only: REAL64,INT64 +implicit none +private + +public MAPL_Sleep + +contains + +! wait time in seconds +subroutine MAPL_Sleep(wait_time) +real, intent(in) :: wait_time + +integer(kind=INT64) :: s1,s2,count_max,count_rate,delta +real(kind=REAL64) :: seconds_elapsed + +call system_clock(count=s1,count_rate=count_rate,count_max=count_max) + +do + + call system_clock(count=s2) + delta = s2-s1 + if (delta < 0) delta= s2 + (count_max - mod(s1,count_max)) + seconds_elapsed = dble(delta)/dble(count_rate) + if (seconds_elapsed > wait_time) exit + +enddo + +end subroutine +end module MAPL_SleepMod diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index 404e987803a1..859c3e5392c4 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -21,5 +21,6 @@ module MaplShared use mapl_CommGroupDescriptionMod use mapl_AbstractCommSplitterMod use mapl_DownbitMod + use mapl_sleepMod end module MaplShared diff --git a/tutorial/driver_app/Example_Driver.F90 b/tutorial/driver_app/Example_Driver.F90 index f489f358637f..f974d002a624 100644 --- a/tutorial/driver_app/Example_Driver.F90 +++ b/tutorial/driver_app/Example_Driver.F90 @@ -8,12 +8,11 @@ program Example_Driver implicit none type (MAPL_Cap) :: cap - type (MAPL_FlapCLI) :: cli + type (MAPL_FargparseCLI) :: cli type (MAPL_CapOptions) :: cap_options integer :: status - cli = MAPL_FlapCLI(description = 'GEOS AGCM', & - authors = 'GMAO') + cli = MAPL_FargparseCLI() cap_options = MAPL_CapOptions(cli) cap = MAPL_Cap('example', cap_options = cap_options) call cap%run(_RC)