diff --git a/.circleci/config.yml b/.circleci/config.yml index de9f64bfa511..58c5b8ee9a8d 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -33,7 +33,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL @@ -49,7 +49,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false @@ -60,6 +60,21 @@ workflows: # ExtData1G tests were removed from ESSENTIAL, so we run them separately here as UFS might still use 1G? ctest_options: "-L 'ESSENTIAL|EXTDATA1G_SMALL_TESTS' --output-on-failure" + # Builds MAPL without pFUnit support + - ci/build: + name: build-MAPL-without-pFUnit-on-<< matrix.compiler >> + context: + - docker-hub-creds + matrix: + parameters: + compiler: [ifort, ifx] + baselibs_version: *baselibs_version + repo: MAPL + mepodevelop: false + remove_pfunit: true + run_unit_tests: true + ctest_options: "-L 'ESSENTIAL' --output-on-failure" + # Run MAPL Tutorials - ci/run_mapl_tutorial: name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> @@ -67,7 +82,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] tutorial_name: - hello_world - parent_no_children @@ -89,7 +104,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true @@ -104,7 +119,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [gfortran, ifort, ifx] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm @@ -185,23 +200,23 @@ workflows: compiler_version: "2021.13" image_name: geos-env tag_build_arg_name: *tag_build_arg_name - #- ci/publish_docker: - #filters: - #tags: - #only: /^v.*$/ - #name: publish-ifx-docker-image - #context: - #- docker-hub-creds - #- ghcr-creds - #os_version: *os_version - #baselibs_version: *baselibs_version - #container_name: mapl - #mpi_name: intelmpi - #mpi_version: "2021.13" - #compiler_name: ifx - #compiler_version: "2024.2" - #image_name: geos-env - #tag_build_arg_name: *tag_build_arg_name + - ci/publish_docker: + filters: + tags: + only: /^v.*$/ + name: publish-ifx-docker-image + context: + - docker-hub-creds + - ghcr-creds + os_version: *os_version + baselibs_version: *baselibs_version + container_name: mapl + mpi_name: intelmpi + mpi_version: "2021.14" + compiler_name: ifx + compiler_version: "2025.0" + image_name: geos-env + tag_build_arg_name: *tag_build_arg_name - ci/publish_docker: filters: tags: @@ -214,8 +229,8 @@ workflows: baselibs_version: *baselibs_version container_name: mapl mpi_name: openmpi - mpi_version: 5.0.2 + mpi_version: 5.0.5 compiler_name: gcc - compiler_version: 13.2.0 + compiler_version: 14.2.0 image_name: geos-env-mkl tag_build_arg_name: *tag_build_arg_name diff --git a/CHANGELOG.md b/CHANGELOG.md index 16bea1129ed9..4458f034c4c7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,59 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.51.0] - 2024-12-06 + +### Added + +- Added macro `_RETURN(_SUCCESS)` to fetch_data +- Allow update offsets of ±timestep in ExtData2G +- Minor revision (and generalization) of grid-def for GSI purposes +- Add ability to use an `ESMF_CONFIG_FILE` environment variable to specify name of 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. +- Allow lat-lon grid factory to detect and use CF compliant lat-lon bounds in a file when making a grid +- PFIO/Variable class, new procedures to retrieve string/reals/int attributes from a variable +- Added a call in GenericRefresh to allow GC's refresh method to be called; in support + of CICE6 rewind + +### Changed + +- Change minimum CMake version to 3.24 + - This is needed for f2py and meson support +- Refactored tableEnd check +- Added commandline options to `checkpoint_benchmark.x` and `restart_benchmark.x` to allow for easier testing of different configurations. Note that the old configuration file style of input is allowed via the `--config_file` option (which overrides any other command line options) +- Update ESMF version for Baselibs to match that of Spack for consistency +- Update `components.yaml` + - ESMA_env v4.32.0 + - Baselibs 7.27.0 + - ESMF 8.7.0 + - curl 8.10.1 + - NCO 5.2.8 + - CDO 2.4.4 + - GSL 2.8 + - jpeg 9f + - Various build fixes + - ESMA_cmake v3.55.0 + - Fixes for using MAPL as a library in spack builds of GEOSgcm + - Various backports from v4 + - Code for capturing `mepo status` output + - Fixes for f2py and meson (NOTE: Requires CMake minimum version of 3.24 in project for complete functionality) + - Fixes for `MPI_STACK` code run multiple times +- Updates to CI + - Use v7.27.0 Baselibs + - Use GCC 14 for GNU tests + - Add pFUnit-less build test + - Enable ifx tests +- Improve some writes to be more informative + - In `base/MAPL_CFIO.F90`, added `Iam` to a print statement so that when a read fails we know which routine failed + - In `gridcomps/ExtData2G/ExtDataConfig.F90`, print out the name of the duplicate collection that causes model to fail + +### Fixed + +- Fixed issue of some Baselibs builds appearing to support zstandard. This is not possible due to Baselibs building HDF5 and netCDF as static libraries +- Workaround ifx bug in `pfio/ArrayReference.F90` (NOTE: This currently targets all versions of ifx, but will need to be qualified or removed in the future) +- Updates to support llvm-flang +- Trajectory sampler: fix a bug when group_name does not exist in netCDF file and a bug that omitted the first time point +- Fixed a bug where the periodicity around the earth of the lat-lon grid was not being set properly when grid did not span from pole to pole + ## [2.50.3] - 2024-12-02 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index e39c76bf75cf..cfbafb015abd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required (VERSION 3.23) +cmake_minimum_required (VERSION 3.24) get_property(is_multi_config GLOBAL PROPERTY GENERATOR_IS_MULTI_CONFIG) if(NOT is_multi_config AND NOT (CMAKE_BUILD_TYPE OR DEFINED ENV{CMAKE_BUILD_TYPE})) @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.50.3 + VERSION 2.51.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui @@ -156,8 +156,8 @@ 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.6.0) - message(FATAL_ERROR "ESMF must be at least 8.6.0") + if (ESMF_VERSION VERSION_LESS 8.6.1) + message(FATAL_ERROR "ESMF must be at least 8.6.1") endif () endif () diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 43ffa5fb4f06..f5fb9ddfe640 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -1,14 +1,5 @@ esma_set_this (OVERRIDE MAPL.base) -if(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 20) - if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER 17) - add_definitions(-D__ifort_18) - endif() - endif() -endif() - - set (srcs MAPL_Profiler.F90 CFIOCollection.F90 MAPL_RegridderManager.F90 diff --git a/base/FileMetadataUtilities.F90 b/base/FileMetadataUtilities.F90 index ea8c858f7ccb..133037ce3c4a 100644 --- a/base/FileMetadataUtilities.F90 +++ b/base/FileMetadataUtilities.F90 @@ -116,30 +116,15 @@ function get_var_attr_real32(this,var_name,attr_name,rc) result(attr_real32) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - real(REAL32) :: tmp(1) - real(REAL64) :: tmpd(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(real(kind=REAL32)) - tmp = attr_val - attr_real32 = tmp(1) - type is(real(kind=REAL64)) - tmpd = attr_val - attr_real32 = REAL(tmpd(1)) - class default - _FAIL('unsupported subclass (not real32) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_real32 = var%get_attribute_real32(attr_name, rc=status) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_real32 @@ -151,28 +136,17 @@ function get_var_attr_real64(this,var_name,attr_name,rc) result(attr_real64) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - real(REAL64) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(real(kind=REAL64)) - tmp = attr_val - attr_real64 = tmp(1) - class default - _FAIL('unsupported subclass (not real64) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select - + attr_real64 = var%get_attribute_real64(attr_name, rc=status) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) + end function get_var_attr_real64 function get_var_attr_int32(this,var_name,attr_name,rc) result(attr_int32) @@ -182,26 +156,15 @@ function get_var_attr_int32(this,var_name,attr_name,rc) result(attr_int32) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - integer(INT32) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(integer(kind=INT32)) - tmp = attr_val - attr_int32 = tmp(1) - class default - _FAIL('unsupported subclass (not int32) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_int32 = var%get_attribute_int32(attr_name, rc=status) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int32 @@ -213,26 +176,15 @@ function get_var_attr_int64(this,var_name,attr_name,rc) result(attr_int64) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - integer(INT64) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(integer(kind=INT64)) - tmp = attr_val - attr_int64 = tmp(1) - class default - _FAIL('unsupported subclass (not int64) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_int64 = var%get_attribute_int64(attr_name, rc=status) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int64 @@ -246,22 +198,13 @@ function get_var_attr_string(this,var_name,attr_name,rc) result(attr_string) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_value() - select type(attr_val) - type is(character(*)) - attr_string = attr_val - class default - _FAIL('unsupported subclass (not string) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_string = var%get_attribute_string(attr_name, rc=status) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_string diff --git a/base/MAPL_CFIO.F90 b/base/MAPL_CFIO.F90 index eeef17d68e43..87b787edaf91 100644 --- a/base/MAPL_CFIO.F90 +++ b/base/MAPL_CFIO.F90 @@ -2840,8 +2840,8 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & call fill_grads_template ( filename, filetmpl, & experiment_id=EXPID, nymd=nymd, nhms=nhms, rc=status ) _VERIFY(STATUS) - !call WRITE_PARALLEL("CFIO: Reading " // trim(filename)) - if (mapl_am_i_root()) write(*,*)"CFIO: Reading ",trim(filename)," at ",nymd," ",nhms + + if (mapl_am_i_root()) write(*,'(a, ": Reading ", a, " at ", i8, " ", i6)') Iam, trim(filename), nymd, nhms cfioIsCreated = .false. diff --git a/base/MAPL_DefGridName.F90 b/base/MAPL_DefGridName.F90 index c6eeb8504f03..72372da7199c 100644 --- a/base/MAPL_DefGridName.F90 +++ b/base/MAPL_DefGridName.F90 @@ -5,38 +5,16 @@ subroutine MAPL_DefGridName (im,jm,gridname,iamroot) character(len=*),intent(out)::gridname character(len=2) poletype character(len=3) llcb -character(len=30) myfmt +character(len=30) imstr,jmstr poletype='PC' if(mod(jm,2)==0) poletype='PE' llcb='-DC' ! lat-lon if(6*im==jm) llcb='-CF' ! cubed -! there has to be a smarter way to do this format -if(im>10.and.im<100.and.& - jm>10.and.jm<100) then - myfmt='(a,i2,a,i2,a)' -endif -if(im>100.and.im<1000.and.& - jm>10.and.jm<100) then - myfmt='(a,i3,a,i2,a)' -endif -if(im>100.and.im<1000.and.& - jm>100.and.jm<1000) then - myfmt='(a,i3,a,i3,a)' -endif -if(im>1000.and.im<10000.and.& - jm>100 .and.jm<1000) then - myfmt='(a,i4,a,i3,a)' -endif -if(im>100 .and.im<1000.and.& - jm>1000.and.jm<100) then - myfmt='(a,i3,a,i4,a)' -endif -if(im>1000.and.im<10000.and.& - jm>1000.and.jm<10000) then - myfmt='(a,i4,a,i4,a)' -endif -write(gridname,fmt=trim(myfmt)) trim(poletype),im,'x',jm,trim(llcb) -if(iamroot)print*,'MAPL_DefGridName: ',trim(gridname) +write(imstr,'(I0)') im +write(jmstr,'(I0)') jm + +gridname=trim(poletype)//trim(imstr) // 'x' // trim(jmstr) // trim(llcb) + end subroutine MAPL_DefGridName diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index fbbbfe3a41e7..b7d076e5a2a3 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -56,6 +56,8 @@ module MAPL_LatLonGridFactoryMod integer :: px, py logical :: is_halo_initialized = .false. logical :: periodic = .true. + character(len=:), allocatable :: lon_bounds_name + character(len=:), allocatable :: lat_bounds_name contains procedure :: make_new_grid procedure :: create_basic_grid @@ -218,10 +220,16 @@ function create_basic_grid(this, unusable, rc) result(grid) integer, optional, intent(out) :: rc integer :: status + type(ESMF_PoleKind_Flag) :: polekindflag(2) _UNUSED_DUMMY(unusable) if (this%periodic) then + if (this%pole == "XY") then + polekindflag = ESMF_POLEKIND_NONE + else + polekindflag = ESMF_POLEKIND_MONOPOLE + end if grid = ESMF_GridCreate1PeriDim( & & name = this%grid_name, & & countsPerDEDim1=this%ims, & @@ -232,6 +240,7 @@ function create_basic_grid(this, unusable, rc) result(grid) & coordDep1=[1,2], & & coordDep2=[1,2], & & coordSys=ESMF_COORDSYS_SPH_RAD, & + & polekindflag=polekindflag, & & rc=status) _VERIFY(status) else @@ -673,7 +682,7 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi integer :: i_min, i_max real(kind=REAL64) :: d_lat, d_lat_temp, extrap_lat - logical :: is_valid, use_file_coords, compute_lons, compute_lats + logical :: is_valid, use_file_coords, compute_lons, compute_lats, has_bnds _UNUSED_DUMMY(unusable) @@ -759,6 +768,11 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi where(this%lon_centers > 180) this%lon_centers=this%lon_centers-360 end if + has_bnds = coordinate_has_bounds(file_metadata, lon_name, _RC) + if (has_bnds) then + this%lon_bounds_name = get_coordinate_bounds_name(file_metadata, lon_name, _RC) + this%lon_corners = get_coordinate_bounds(file_metadata, lon_name, _RC) + end if v => file_metadata%get_coordinate_variable(lat_name, rc=status) _VERIFY(status) @@ -773,6 +787,12 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi _FAIL('unsupported type of data; must be REAL32 or REAL64') end select + has_bnds = coordinate_has_bounds(file_metadata, lat_name, _RC) + if (has_bnds) then + this%lat_bounds_name = get_coordinate_bounds_name(file_metadata, lat_name, _RC) + this%lat_corners = get_coordinate_bounds(file_metadata, lat_name, _RC) + end if + ! Check: is this a "mis-specified" pole-centered grid? if (size(this%lat_centers) >= 4) then @@ -804,14 +824,14 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi end if end if - ! Corners are the midpoints of centers (and extrapolated at the ! poles for lats.) - allocate(this%lon_corners(im+1), this%lat_corners(jm+1)) - - this%lon_corners(1) = (this%lon_centers(im) + this%lon_centers(1))/2 - 180 - this%lon_corners(2:im) = (this%lon_centers(1:im-1) + this%lon_centers(2:im))/2 - this%lon_corners(im+1) = (this%lon_centers(im) + this%lon_centers(1))/2 + 180 + if (.not. allocated(this%lon_corners)) then + allocate(this%lon_corners(im+1)) + this%lon_corners(1) = (this%lon_centers(im) + this%lon_centers(1))/2 - 180 + this%lon_corners(2:im) = (this%lon_centers(1:im-1) + this%lon_centers(2:im))/2 + this%lon_corners(im+1) = (this%lon_centers(im) + this%lon_centers(1))/2 + 180 + end if ! This section about pole/dateline is probably not needed in file data case. if (abs(this%lon_centers(1) + 180) < 1000*epsilon(1.0)) then @@ -826,10 +846,13 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi this%dateline = 'XY' this%lon_range = RealMinMax(this%lon_centers(1), this%lon_centers(jm)) end if - - this%lat_corners(1) = this%lat_centers(1) - (this%lat_centers(2)-this%lat_centers(1))/2 - this%lat_corners(2:jm) = (this%lat_centers(1:jm-1) + this%lat_centers(2:jm))/2 - this%lat_corners(jm+1) = this%lat_centers(jm) - (this%lat_centers(jm-1)-this%lat_centers(jm))/2 + + if (.not. allocated(this%lat_corners)) then + allocate(this%lat_corners(jm+1)) + this%lat_corners(1) = this%lat_centers(1) - (this%lat_centers(2)-this%lat_centers(1))/2 + this%lat_corners(2:jm) = (this%lat_centers(1:jm-1) + this%lat_centers(2:jm))/2 + this%lat_corners(jm+1) = this%lat_centers(jm) - (this%lat_centers(jm-1)-this%lat_centers(jm))/2 + end if if (abs(this%lat_centers(1) + 90) < 1000*epsilon(1.0)) then this%pole = 'PC' @@ -1139,7 +1162,6 @@ subroutine check_and_fill_consistency(this, unusable, rc) ! Check regional vs global if (this%pole == 'XY') then ! regional - this%periodic = .false. _ASSERT(this%lat_range%min /= MAPL_UNDEFINED_REAL, 'uninitialized min for lat_range') _ASSERT(this%lat_range%max /= MAPL_UNDEFINED_REAL, 'uninitialized min for lat_range') else ! global @@ -1849,9 +1871,16 @@ function get_file_format_vars(this) result(vars) class (LatLonGridFactory), intent(inout) :: this character(len=:), allocatable :: vars + integer :: i _UNUSED_DUMMY(this) vars = 'lon,lat' + if (allocated(this%lon_bounds_name)) then + vars = vars // ',' // this%lon_bounds_name + end if + if (allocated(this%lat_bounds_name)) then + vars = vars // ',' // this%lat_bounds_name + end if end function get_file_format_vars @@ -1928,5 +1957,85 @@ function generate_file_reference3D(this,fpointer,metaData) result(ref) _UNUSED_DUMMY(metaData) end function generate_file_reference3D + function coordinate_has_bounds(metadata, coord_name, rc) result(has_bounds) + logical :: has_bounds + type(FileMetadata), intent(in) :: metadata + character(len=*), intent(in) :: coord_name + integer, optional, intent(out) :: rc + + type(Variable), pointer :: var + integer :: status + + var => metadata%get_variable(coord_name, _RC) + has_bounds = var%is_attribute_present("bounds") + + _RETURN(_SUCCESS) + end function + + function get_coordinate_bounds_name(metadata, coord_name, rc) result(coord_bounds_name) + character(len=:), allocatable :: coord_bounds_name + type(FileMetadata), intent(in) :: metadata + character(len=*), intent(in) :: coord_name + integer, optional, intent(out) :: rc + + type(Variable), pointer :: var + type(Attribute), pointer :: attr + integer :: status + class(*), pointer :: attr_val + + var => metadata%get_variable(coord_name, _RC) + attr => var%get_attribute("bounds", _RC) + attr_val => attr%get_value() + select type(attr_val) + type is(character(*)) + coord_bounds_name = attr_val + class default + _FAIL('coordinate bounds must be a string') + end select + _RETURN(_SUCCESS) + end function + + function get_coordinate_bounds(metadata, coord_name, rc) result(coord_bounds) + real(kind=REAL64), allocatable :: coord_bounds(:) + type(FileMetadata), intent(in) :: metadata + character(len=*), intent(in) :: coord_name + integer, optional, intent(out) :: rc + + type(Variable), pointer :: var + type(Attribute), pointer :: attr + integer :: status, im, i + class(*), pointer :: attr_val + character(len=:), allocatable :: bnds_name, source_file + real(kind=REAL64), allocatable :: file_bounds(:,:) + type(NetCDF4_FileFormatter) :: file_formatter + + + var => metadata%get_variable(coord_name, _RC) + attr => var%get_attribute("bounds", _RC) + attr_val => attr%get_value() + select type(attr_val) + type is(character(*)) + bnds_name = attr_val + class default + _FAIL('coordinate bounds must be a string') + end select + im = metadata%get_dimension(coord_name, _RC) + allocate(coord_bounds(im+1), _STAT) + allocate(file_bounds(2,im), _STAT) + source_file = metadata%get_source_file() + + call file_formatter%open(source_file, PFIO_READ, _RC) + call file_formatter%get_var(bnds_name, file_bounds, _RC) + call file_formatter%close(_RC) + do i=1,im-1 + _ASSERT(file_bounds(2,i)==file_bounds(1,i+1), "Bounds are not contiguous in file") + enddo + do i=1,im + coord_bounds(i) = file_bounds(1,i) + coord_bounds(i+1) = file_bounds(2,i) + enddo + + _RETURN(_SUCCESS) + end function end module MAPL_LatLonGridFactoryMod diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index 8733f178b3ab..b9c163816647 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -218,20 +218,21 @@ subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name, rc) real(REAL64), dimension(Xdim), intent(out) :: array integer, optional, intent(out) :: rc integer :: status - integer :: ncid, varid, ncid2 + integer :: ncid, varid, ncid2, ncid_sv call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid + if(present(group_name)) then - ncid2= ncid - call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + if(group_name/='') then + ncid2= ncid + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + end if end if call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) call check_nc_status(nf90_get_var(ncid, varid, array), _RC) - if(present(group_name)) then - call check_nc_status(nf90_close(ncid2), _RC) - else - call check_nc_status(nf90_close(ncid), _RC) - end if + + call check_nc_status(nf90_close(ncid_sv), _RC) _RETURN(_SUCCESS) end subroutine get_v1d_netcdf_R8 @@ -256,9 +257,11 @@ subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_va call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then - call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) - ! mod - ncid = ncid_grp + if(group_name/='') then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! mod + ncid = ncid_grp + end if end if call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) call check_nc_status(nf90_get_var(ncid, varid, array), _RC) @@ -296,9 +299,11 @@ subroutine get_att_real_netcdf(filename, varname, att_name, att_value, group_nam call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then - call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) - ! overwrite - ncid = ncid_grp + if(group_name/='') then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp + end if end if call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) @@ -324,9 +329,11 @@ subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_nam call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then - call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) - ! overwrite - ncid = ncid_grp + if(group_name/='') then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp + end if end if call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) diff --git a/benchmarks/io/checkpoint_simulator/README.md b/benchmarks/io/checkpoint_simulator/README.md index 4466e69af71f..bce5cf452ab0 100644 --- a/benchmarks/io/checkpoint_simulator/README.md +++ b/benchmarks/io/checkpoint_simulator/README.md @@ -1,6 +1,27 @@ This benchmark simulates writing a series of 3D variables of a given cubed-sphere resolution to a file using the same strategies as used by the real checkpoint code in MAPL -The code has the following options and needs an ESMF rc file named checkpoint\_benchmark.rc +The code has the following command line options: +``` + optional arguments: + -h, --help This message. + --config_file The configuration file to use + --nx The number of cells in the x direction (default: 4) + --ny The number of cells in the y direction (default: 4) + --im_world The resolution of the cubed sphere (default: 90) + --lm The number of levels in each 3D variable (default: 137) + --num_writers The number of processes that will write (default: 1) + --num_arrays The number of 3D arrays to write (default: 5) + --ntrials The number of trials to run (default: 3) + --split_file Split the file into multiple files (default: do not split) + --gather_3d Gather all levels at once instead of one at a time (default: gather one at a time) + --write_barrier Add a barrier after every write (default: no barrier) + --static_data Use static data (rank of process) instead of random data (default: random data) + --suppress_writes Do not write data (default: write data) + --write_binary Write binary data instead of NetCDF (default: write NetCDF) + --no_chunking Do not chunk output (default: chunk the output) +``` + +NOTE 1: If you specify a `config_file` it must be an ESMF Config file with the following options: - "NX:" the x distribution for each face - "NY:" the y distribution for each face @@ -8,12 +29,12 @@ The code has the following options and needs an ESMF rc file named checkpoint\_b - "LM:" the number of levels - "NUM\_WRITERS:" the number of writing processes either to a single or independent files - "NUM\_ARRAYS:" the number of 3D variables to write to the file -- "CHUNK:" whether to chunk, default true -- "GATHER\_3D:" gather all levels at once (default is false which means a level at a time is gathered) -- "SPLIT\_FILE:" default false, if true, each writer writes to and independent file -- "WRITE\_BARRIER:" default false, add a barrier before each write to for synchronization -- "DO\_WRITES:" default true, if false skips writing (so just an mpi test at that point) -- "NTRIALS:" default 1, the number of trials to make writing -- "RANDOM\_DATA:" default true, if true will arrays with random data, if false sets the array to the rank of the process +- "CHUNK:" whether to chunk, default `.true.` +- "GATHER\_3D:" gather all levels at once (default is `.false.` which means a level at a time is gathered) +- "SPLIT\_FILE:" default `.false.`, if `.true.`, each writer writes to and independent file +- "WRITE\_BARRIER:" default `.false.`, add a barrier before each write to for synchronization +- "DO\_WRITES:" default `.true.`, if `.false.` skips writing (so just an mpi test at that point) +- "NTRIALS:" default 3, the number of trials to make writing +- "RANDOM\_DATA:" default `.true.`, if `.true.` will arrays with random data, if `.false.` sets the array to the rank of the process -Note that whatever you set NX and NY to the program must be run on `6*NX*NY` processors and the number of writers must evenly divide `6*NY` +NOTE 2: that whatever you set NX and NY to the program must be run on `6*NX*NY` processors and the number of writers must evenly divide `6*NY` diff --git a/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 index 96bad4dfd6a5..3627e50ffde3 100644 --- a/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 +++ b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 @@ -6,6 +6,7 @@ module mapl_checkpoint_support_mod use MPI use NetCDF use MAPL_ErrorHandlingMod + use fargparse use, intrinsic :: iso_fortran_env, only: INT64, REAL64, REAL32 implicit none @@ -45,7 +46,8 @@ module mapl_checkpoint_support_mod integer(kind=INT64) :: create_file_time integer(kind=INT64) :: close_file_time contains - procedure :: set_parameters + procedure :: set_parameters_by_config + procedure :: set_parameters_by_cli procedure :: compute_decomposition procedure :: allocate_n_arrays procedure :: create_arrays @@ -58,9 +60,178 @@ module mapl_checkpoint_support_mod procedure :: reset end type + type cli_options + integer :: nx + integer :: ny + integer :: im_world + integer :: lm + integer :: num_writers + integer :: num_arrays + integer :: n_trials + logical :: split_file = .false. + logical :: gather_3d = .false. + logical :: write_barrier = .false. + logical :: random_data = .true. + logical :: do_writes = .true. + logical :: netcdf_writes = .true. + logical :: do_chunking = .true. + character(len=:), allocatable :: config_file + end type cli_options + contains - subroutine set_parameters(this,config_file) + function parse_arguments() result(options) + + type(StringUnlimitedMap) :: options + type(ArgParser), target :: parser + + call parser%initialize('checkpoint_simulator.x') + parser = ArgParser() + + call parser%add_argument("--config_file", & + help="The configuration file to use", & + action="store", & + type="string") + + call parser%add_argument("--nx", & + help="The number of cells in the x direction (default: 4)", & + action="store", & + type="integer", & + default=4) + + call parser%add_argument("--ny", & + help="The number of cells in the y direction (default: 4)", & + action="store", & + type="integer", & + default=4) + + call parser%add_argument("--im_world", & + help="The resolution of the cubed sphere (default: 90)", & + action="store", & + type="integer", & + default=90) + + call parser%add_argument("--lm", & + help="The number of levels in each 3D variable (default: 137)", & + action="store", & + type="integer", & + default=137) + + call parser%add_argument("--num_writers", & + help="The number of processes that will write (default: 1)", & + action="store", & + type="integer", & + default=1) + + call parser%add_argument("--num_arrays", & + help="The number of 3D arrays to write (default: 5)", & + action="store", & + type="integer", & + default=5) + + call parser%add_argument("--ntrials", & + help="The number of trials to run (default: 3)", & + action="store", & + type="integer", & + default=3) + + call parser%add_argument("--split_file", & + help="Split the file into multiple files (default: do not split)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--gather_3d", & + help="Gather all levels at once instead of one at a time (default: gather one at a time)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--write_barrier", & + help="Add a barrier after every write (default: no barrier)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--static_data", & + help="Use static data (rank of process) instead of random data (default: random data)", & + action="store_true", & + default=.False.) + + call parser%add_argument("--suppress_writes", & + help="Do not write data (default: write data)", & + action="store_true", & + default=.False.) + + call parser%add_argument("--write_binary", & + help="Write binary data instead of NetCDF (default: write NetCDF)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--no_chunking", & + help="Do not chunk output (default: chunk the output)", & + action="store_true", & + default=.false.) + + options = parser%parse_args() + + end function parse_arguments + + subroutine get_cli_options(options, cli) + type(StringUnlimitedMap), intent(in) :: options + type(cli_options), intent(out) :: cli + class(*), pointer :: option + logical :: tmp + + option => options%at("config_file") + if (associated(option)) call cast(option, cli%config_file) + + option => options%at("nx") + if (associated(option)) call cast(option, cli%nx) + + option => options%at("ny") + if (associated(option)) call cast(option, cli%ny) + + option => options%at("im_world") + if (associated(option)) call cast(option, cli%im_world) + + option => options%at("lm") + if (associated(option)) call cast(option, cli%lm) + + option => options%at("num_writers") + if (associated(option)) call cast(option, cli%num_writers) + + option => options%at("num_arrays") + if (associated(option)) call cast(option, cli%num_arrays) + + option => options%at("ntrials") + if (associated(option)) call cast(option, cli%n_trials) + + option => options%at("split_file") + if (associated(option)) call cast(option, cli%split_file) + + option => options%at("gather_3d") + if (associated(option)) call cast(option, cli%gather_3d) + + option => options%at("write_barrier") + if (associated(option)) call cast(option, cli%write_barrier) + + option => options%at("static_data") + if (associated(option)) call cast(option, tmp) + cli%random_data = .not. tmp + + option => options%at("suppress_writes") + if (associated(option)) call cast(option, tmp) + cli%do_writes = .not. tmp + + option => options%at("write_binary") + if (associated(option)) call cast(option, tmp) + cli%netcdf_writes = .not. tmp + + option => options%at("no_chunking") + if (associated(option)) call cast(option, tmp) + cli%do_chunking = .not. tmp + + end subroutine get_cli_options + + subroutine set_parameters_by_config(this,config_file) class(test_support), intent(inout) :: this character(len=*), intent(in) :: config_file type(ESMF_Config) :: config @@ -86,7 +257,7 @@ subroutine set_parameters(this,config_file) this%write_barrier = get_logical_key(config,"WRITE_BARRIER:",.false.) this%do_writes = get_logical_key(config,"DO_WRITES:",.true.) this%netcdf_writes = get_logical_key(config,"NETCDF_WRITES:",.true.) - this%n_trials = get_integer_key(config,"NTRIALS:",1) + this%n_trials = get_integer_key(config,"NTRIALS:",3) this%random = get_logical_key(config,"RANDOM_DATA:",.true.) this%write_counter = 0 @@ -136,7 +307,47 @@ function get_integer_key(config,label,default_val) result(val) end if end function - end subroutine + end subroutine set_parameters_by_config + + subroutine set_parameters_by_cli(this,cli) + class(test_support), intent(inout) :: this + type(cli_options), intent(in) :: cli + + logical :: is_present + integer :: comm_size, status,error_code,rc + + this%extra_info = .false. + this%write_barrier = cli%write_barrier + this%do_writes = cli%do_writes + this%netcdf_writes = cli%netcdf_writes + this%do_chunking = cli%do_chunking + this%gather_3d = cli%gather_3d + this%split_file = cli%split_file + this%nx = cli%nx + this%ny = cli%ny + this%im_world = cli%im_world + this%lm = cli%lm + this%num_writers = cli%num_writers + this%num_arrays = cli%num_arrays + this%n_trials = cli%n_trials + this%random = cli%random_data + + this%write_counter = 0 + this%write_3d_time = 0 + this%write_2d_time = 0 + this%create_file_time = 0 + this%close_file_time = 0 + this%data_volume = 0.d0 + this%time_writing = 0.d0 + this%mpi_time = 0.0 + call MPI_COMM_SIZE(MPI_COMM_WORLD,comm_size,status) + _VERIFY(status) + if (comm_size /= (this%nx*this%ny*6)) then + call MPI_Abort(mpi_comm_world,error_code,status) + _VERIFY(status) + endif + + end subroutine set_parameters_by_cli subroutine reset(this) class(test_support), intent(inout) :: this @@ -356,20 +567,25 @@ subroutine create_file(this) write(fc,'(I0.3)')writer_rank fname = "checkpoint_"//fc//".nc4" status = nf90_create(fname,ior(NF90_NETCDF4,NF90_CLOBBER), this%ncid) + _VERIFY(status) chunk_factor = 1 else fname = "checkpoint.nc4" status = nf90_create(fname,create_mode, this%ncid, comm=this%writers_comm, info=info) + _VERIFY(status) chunk_factor = this%num_writers end if status = nf90_def_dim(this%ncid,"lon",this%im_world,xdim) + _VERIFY(status) if (this%split_file) then y_size = this%im_world*6/this%num_writers else y_size = this%im_world*6 end if status = nf90_def_dim(this%ncid,"lat",y_size,ydim) + _VERIFY(status) status = nf90_def_dim(this%ncid,"lev",this%lm,zdim) + _VERIFY(status) if (this%gather_3d) then z_chunk = this%lm else @@ -378,11 +594,15 @@ subroutine create_file(this) do i=1,this%num_arrays if (this%do_chunking) then status = nf90_def_var(this%ncid,this%bundle(i)%field_name,NF90_FLOAT,[xdim,ydim,zdim],varid,chunksizes=[this%im_world,y_size/chunk_factor,z_chunk]) + _VERIFY(status) else status = nf90_def_var(this%ncid,this%bundle(i)%field_name,NF90_FLOAT,[xdim,ydim,zdim],varid) + _VERIFY(status) end if status = nf90_def_var_fill(this%ncid,varid,NF90_NOFILL,0) + _VERIFY(status) !status = nf90_var_par_access(this%ncid,varid,NF90_COLLECTIVE) ! you can turn this on if you really want to hork up performance + !_VERIFY(status) enddo status = nf90_enddef(this%ncid) end if @@ -481,15 +701,19 @@ subroutine write_variable(this,var_name,local_var) jsize=jsize + (this%jn(myrow+j) - this%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize,this%lm), stat=status) + _VERIFY(status) allocate(recvbuf(IM_WORLD*jsize*this%lm), stat=status) + _VERIFY(status) end if if(myiorank/=0) then allocate(recvbuf(0), stat=status) + _VERIFY(status) endif call mpi_gatherv( local_var, size(local_var), MPI_REAL, recvbuf, recvcounts, displs, MPI_REAL, & 0, this%gather_comm, status ) + _VERIFY(status) call system_clock(count=end_mpi) this%time_mpi = this%mpi_time + (end_mpi - start_mpi) if (this%write_barrier) then @@ -532,7 +756,9 @@ subroutine write_variable(this,var_name,local_var) if (this%do_writes) then if (this%netcdf_writes) then status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + _VERIFY(status) status = nf90_put_var(this%ncid,varid,var,start,cnt) + _VERIFY(status) else write(this%ncid)var end if @@ -649,7 +875,9 @@ subroutine write_level(this,var_name,local_var,z_index) if (this%do_writes) then if (this%netcdf_writes) then status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + _VERIFY(status) status = nf90_put_var(this%ncid,varid,var,start,cnt) + _VERIFY(status) else write(this%ncid)var end if @@ -679,6 +907,7 @@ program checkpoint_tester use mapl_checkpoint_support_mod use MPI use NetCDF + use fargparse use, intrinsic :: iso_fortran_env, only: REAL64, INT64 implicit NONE @@ -692,6 +921,9 @@ program checkpoint_tester real(kind=REAL64) :: mean_throughput, mean_fs_throughput real(kind=REAL64) :: std_throughput, std_fs_throughput + type(StringUnlimitedMap) :: options + type(cli_options) :: cli + call system_clock(count=start_app,count_rate=count_rate) call MPI_Init(status) _VERIFY(status) @@ -706,7 +938,19 @@ program checkpoint_tester call MPI_Barrier(MPI_COMM_WORLD,status) _VERIFY(status) - call support%set_parameters("checkpoint_benchmark.rc") + options = parse_arguments() + + call get_cli_options(options,cli) + + ! if we have it, we load the configuration file + if (allocated(cli%config_file)) then + if (rank == 0) write(*,*) "Using configuration file ",cli%config_file + if (rank == 0) write(*,*) "NOTE: This overrides any other command line options" + call support%set_parameters_by_config(cli%config_file) + else + call support%set_parameters_by_cli(cli) + end if + call MPI_Barrier(MPI_COMM_WORLD,status) _VERIFY(status) diff --git a/benchmarks/io/restart_simulator/README.md b/benchmarks/io/restart_simulator/README.md index 3152425b0575..d89c48741b53 100644 --- a/benchmarks/io/restart_simulator/README.md +++ b/benchmarks/io/restart_simulator/README.md @@ -1,19 +1,40 @@ -This benchmark simulates writing a series of 3D variables of a given cubed-sphere resolution to a file using the same strategies as used by the real checkpoint code in MAPL +This benchmark simulates reading a series of 3D variables of a given cubed-sphere resolution to a file using the same strategies as used by the real checkpoint code in MAPL -The code has the following options and needs an ESMF rc file named checkpoint\_benchmark.rc +The code has the following command line options: + +``` + -h, --help This message. + --config_file The configuration file to use + --nx The number of cells in the x direction (default: 4) + --ny The number of cells in the y direction (default: 4) + --im_world The resolution of the cubed sphere (default: 90) + --lm The number of levels in each 3D variable (default: 137) + --num_readers The number of processes that will read (default: 1) + --num_arrays The number of 3D arrays to read (default: 5) + --ntrials The number of trials to run (default: 3) + --split_file Read split files instead of a single file (default: read single file) + --scatter_3d Scatter all the levels at once instead of one at a time (default: scatter one at a time) + --read_barrier Add a barrier after every read (default: no barrier) + --static_data Use static data (rank of process) instead of random data (default: random data) + --suppress_reads Do not read data (default: read data) + --read_binary Read binary data instead of netCDF (default: netCDF data) +``` + +NOTE 1: This program *REQUIRES* a file called `checkpoint.nc4` that is generated by the `checkpoint_benchmark.x` code. + +NOTE 2: If you specify a `config_file` it must be an ESMF Config file with the following options: - "NX:" the x distribution for each face - "NY:" the y distribution for each face - "IM\_WORLD:" the cube resolution -- "LM:" the nubmer of levels -- "NUM\_WRITERS:" the number of writing processes either to a single or independent files -- "NUM\_ARRAYS:" the number of 3D variables to write to the file -- "CHUNK:" whether to chunk, default true -- "SCATTER\_3D:" gather all levels at once (default is false which means a level at a time is gathered) -- "SPLIT\_FILE:" default false, if true, each writer writes to and independent file -- "WRITE\_BARRIER:" default false, add a barrier before each write to for synchronization -- "DO\_WRITES:" default true, if false skips writing (so just an mpi test at that point) -- "NTRIAL:" default 1, the number of trials to make writing -- "RANDOM\_DATA:" default true, if true will arrays with random data, if false sets the array to the rank of the process +- "LM:" the number of levels +- "NUM\_READERS:" the number of reading processes either from a single or independent files +- "NUM\_ARRAYS:" the number of 3D variables to read from the file +- "SCATTER\_3D:" scatter all levels at once (default is `.false` which means a level at a time is gathered) +- "SPLIT\_FILE:" default `.false`, if `.true.`, each reader reads from an independent file +- "READ\_BARRIER:" default `.false`, add a barrier before each read for synchronization +- "DO\_READS:" default `.true.`, if `.false` skips reading (so just an mpi test at that point) +- "NTRIALS:" default 3, the number of trials to make for each read +- "RANDOM\_DATA:" default `.true.`, if `.true.` will arrays with random data, if `.false` sets the array to the rank of the process -Note that whatever you set NX and NY to the program must be run on 6*NY*NY processors and the number of writers must evenly divide 6*NY +NOTE 3: whatever you set NX and NY to the program must be run on `6*NY*NY` processors and the number of readers must evenly divide `6*NY` diff --git a/benchmarks/io/restart_simulator/restart_simulator.F90 b/benchmarks/io/restart_simulator/restart_simulator.F90 index 235cba280b5b..710b59c2c6c3 100644 --- a/benchmarks/io/restart_simulator/restart_simulator.F90 +++ b/benchmarks/io/restart_simulator/restart_simulator.F90 @@ -6,6 +6,7 @@ module mapl_restart_support_mod use NetCDF use MAPL_ErrorHandlingMod use MAPL_MemUtilsMod + use fargparse use, intrinsic :: iso_fortran_env, only: INT64, REAL64, REAL32 implicit none @@ -44,7 +45,8 @@ module mapl_restart_support_mod integer(kind=INT64) :: open_file_time integer(kind=INT64) :: close_file_time contains - procedure :: set_parameters + procedure :: set_parameters_by_config + procedure :: set_parameters_by_cli procedure :: compute_decomposition procedure :: allocate_n_arrays procedure :: create_arrays @@ -57,14 +59,173 @@ module mapl_restart_support_mod procedure :: reset end type + type cli_options + integer :: nx + integer :: ny + integer :: im_world + integer :: lm + integer :: num_readers + integer :: num_arrays + integer :: n_trials + logical :: split_file = .false. + logical :: scatter_3d = .false. + logical :: read_barrier = .false. + logical :: random_data = .true. + logical :: do_reads = .true. + logical :: netcdf_reads = .true. + character(len=:), allocatable :: config_file + end type cli_options + contains - subroutine set_parameters(this,config_file) + function parse_arguments() result(options) + + type(StringUnlimitedMap) :: options + type(ArgParser), target :: parser + + call parser%initialize('checkpoint_simulator.x') + parser = ArgParser() + + call parser%add_argument("--config_file", & + help="The configuration file to use", & + action="store", & + type="string") + + call parser%add_argument("--nx", & + help="The number of cells in the x direction (default: 4)", & + action="store", & + type="integer", & + default=4) + + call parser%add_argument("--ny", & + help="The number of cells in the y direction (default: 4)", & + action="store", & + type="integer", & + default=4) + + call parser%add_argument("--im_world", & + help="The resolution of the cubed sphere (default: 90)", & + action="store", & + type="integer", & + default=90) + + call parser%add_argument("--lm", & + help="The number of levels in each 3D variable (default: 137)", & + action="store", & + type="integer", & + default=137) + + call parser%add_argument("--num_readers", & + help="The number of processes that will read (default: 1)", & + action="store", & + type="integer", & + default=1) + + call parser%add_argument("--num_arrays", & + help="The number of 3D arrays to read (default: 5)", & + action="store", & + type="integer", & + default=5) + + call parser%add_argument("--ntrials", & + help="The number of trials to run (default: 3)", & + action="store", & + type="integer", & + default=3) + + call parser%add_argument("--split_file", & + help="Read split files instead of a single file (default: read single file)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--scatter_3d", & + help="Scatter all the levels at once instead of one at a time (default: scatter one at a time)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--read_barrier", & + help="Add a barrier after every read (default: no barrier)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--static_data", & + help="Use static data (rank of process) instead of random data (default: random data)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--suppress_reads", & + help="Do not read data (default: read data)", & + action="store_true", & + default=.false.) + + call parser%add_argument("--read_binary", & + help="Read binary data instead of netCDF (default: netCDF data)", & + action="store_true", & + default=.false.) + + options = parser%parse_args() + + end function parse_arguments + + subroutine get_cli_options(options, cli) + type(StringUnlimitedMap), intent(in) :: options + type(cli_options), intent(out) :: cli + class(*), pointer :: option + logical :: tmp + + option => options%at("config_file") + if (associated(option)) call cast(option, cli%config_file) + + option => options%at("nx") + if (associated(option)) call cast(option, cli%nx) + + option => options%at("ny") + if (associated(option)) call cast(option, cli%ny) + + option => options%at("im_world") + if (associated(option)) call cast(option, cli%im_world) + + option => options%at("lm") + if (associated(option)) call cast(option, cli%lm) + + option => options%at("num_readers") + if (associated(option)) call cast(option, cli%num_readers) + + option => options%at("num_arrays") + if (associated(option)) call cast(option, cli%num_arrays) + + option => options%at("ntrials") + if (associated(option)) call cast(option, cli%n_trials) + + option => options%at("split_file") + if (associated(option)) call cast(option, cli%split_file) + + option => options%at("scatter_3d") + if (associated(option)) call cast(option, cli%scatter_3d) + + option => options%at("read_barrier") + if (associated(option)) call cast(option, cli%read_barrier) + + option => options%at("no_random_data") + if (associated(option)) call cast(option, tmp) + cli%random_data = .not. tmp + + option => options%at("do_no_reads") + if (associated(option)) call cast(option, tmp) + cli%do_reads = .not. tmp + + option => options%at("no_netcdf_reads") + if (associated(option)) call cast(option, tmp) + cli%netcdf_reads = .not. tmp + + end subroutine get_cli_options + + subroutine set_parameters_by_config(this,config_file) class(test_support), intent(inout) :: this character(len=*), intent(in) :: config_file type(ESMF_Config) :: config - integer :: comm_size, status,error_code + integer :: comm_size, status,error_code, rc config = ESMF_ConfigCreate() this%extra_info = .false. @@ -80,10 +241,10 @@ subroutine set_parameters(this,config_file) this%scatter_3d = get_logical_key(config,"SCATTER_3D:",.false.) this%split_file = get_logical_key(config,"SPLIT_FILE:",.false.) this%extra_info = get_logical_key(config,"EXTRA_INFO:",.false.) - this%read_barrier = get_logical_key(config,"read_BARRIER:",.false.) + this%read_barrier = get_logical_key(config,"READ_BARRIER:",.false.) this%do_reads = get_logical_key(config,"DO_READS:",.true.) - this%netcdf_reads = get_logical_key(config,"netcdf_reads:",.true.) - this%n_trials = get_integer_key(config,"NTRIALS:",1) + this%netcdf_reads = get_logical_key(config,"NETCDF_READS:",.true.) + this%n_trials = get_integer_key(config,"NTRIALS:",3) this%random = get_logical_key(config,"RANDOM_DATA:",.true.) this%read_counter = 0 @@ -95,7 +256,11 @@ subroutine set_parameters(this,config_file) this%time_reading = 0.d0 this%mpi_time = 0.0 call MPI_COMM_SIZE(MPI_COMM_WORLD,comm_size,status) - if (comm_size /= (this%nx*this%ny*6)) call MPI_Abort(mpi_comm_world,error_code,status) + _VERIFY(status) + if (comm_size /= (this%nx*this%ny*6)) then + call MPI_Abort(mpi_comm_world,error_code,status) + _VERIFY(status) + endif contains @@ -129,7 +294,46 @@ function get_integer_key(config,label,default_val) result(val) end if end function - end subroutine + end subroutine set_parameters_by_config + + subroutine set_parameters_by_cli(this,cli) + class(test_support), intent(inout) :: this + type(cli_options), intent(in) :: cli + + logical :: is_present + integer :: comm_size, status,error_code,rc + + this%extra_info = .false. + this%read_barrier = cli%read_barrier + this%do_reads = cli%do_reads + this%netcdf_reads = cli%netcdf_reads + this%scatter_3d = cli%scatter_3d + this%split_file = cli%split_file + this%nx = cli%nx + this%ny = cli%ny + this%im_world = cli%im_world + this%lm = cli%lm + this%num_readers = cli%num_readers + this%num_arrays = cli%num_arrays + this%n_trials = cli%n_trials + this%random = cli%random_data + + this%read_counter = 0 + this%read_3d_time = 0 + this%read_2d_time = 0 + this%open_file_time = 0 + this%close_file_time = 0 + this%data_volume = 0.d0 + this%time_reading = 0.d0 + this%mpi_time = 0.0 + call MPI_COMM_SIZE(MPI_COMM_WORLD,comm_size,status) + _VERIFY(status) + if (comm_size /= (this%nx*this%ny*6)) then + call MPI_Abort(mpi_comm_world,error_code,status) + _VERIFY(status) + endif + + end subroutine set_parameters_by_cli subroutine reset(this) class(test_support), intent(inout) :: this @@ -170,12 +374,13 @@ subroutine allocate_n_arrays(this,im,jm) integer, intent(in) :: im integer, intent(in) :: jm - integer :: n,rank,status + integer :: n,rank,status,rc character(len=3) :: formatted_int integer :: seed_size integer, allocatable :: seeds(:) call MPI_COMM_RANK(MPI_COMM_WORLD,rank,status) + _VERIFY(status) call random_seed(size=seed_size) allocate(seeds(seed_size)) seeds = rank @@ -196,10 +401,12 @@ subroutine create_arrays(this) class(test_support), intent(inout) :: this integer, allocatable :: ims(:),jms(:) - integer :: rank, status,comm_size,n,i,j,rank_counter,offset,index_offset + integer :: rank, status,comm_size,n,i,j,rank_counter,offset,index_offset,rc call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) + _VERIFY(status) call MPI_Comm_Size(MPI_COMM_WORLD,comm_size,status) + _VERIFY(status) allocate(this%bundle(this%num_arrays)) ims = this%compute_decomposition(axis=1) jms = this%compute_decomposition(axis=2) @@ -248,16 +455,19 @@ subroutine create_arrays(this) subroutine create_communicators(this) class(test_support), intent(inout) :: this - integer :: myid,status,nx0,ny0,color,j,ny_by_readers,local_ny + integer :: myid,status,nx0,ny0,color,j,ny_by_readers,local_ny,rc local_ny = this%ny*6 call MPI_Comm_Rank(mpi_comm_world,myid,status) + _VERIFY(status) nx0 = mod(myid,this%nx) + 1 ny0 = myid/this%nx + 1 color = nx0 call MPI_Comm_Split(MPI_COMM_WORLD,color,myid,this%ycomm,status) + _VERIFY(status) color = ny0 call MPI_Comm_Split(MPI_COMM_WORLD,color,myid,this%xcomm,status) + _VERIFY(status) ny_by_readers = local_ny/this%num_readers @@ -267,15 +477,19 @@ subroutine create_communicators(this) color = MPI_UNDEFINED end if call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,myid,this%readers_comm,status) + _VERIFY(status) + if (this%num_readers == local_ny) then this%scatter_comm = this%xcomm else j = ny0 - mod(ny0-1,ny_by_readers) call MPI_COMM_SPLIT(MPI_COMM_WORLD,j,myid,this%scatter_comm,status) + _VERIFY(status) end if - call MPI_BARRIER(mpi_comm_world,status) + call MPI_BARRIER(mpi_comm_world, status) + _VERIFY(status) end subroutine @@ -283,7 +497,7 @@ subroutine create_communicators(this) subroutine close_file(this) class(test_support), intent(inout) :: this - integer :: status + integer :: status, rc integer(kind=INT64) :: sub_start,sub_end @@ -292,11 +506,13 @@ subroutine close_file(this) if (this%readers_comm /= MPI_COMM_NULL) then if (this%netcdf_reads) then status = nf90_close(this%ncid) + _VERIFY(status) else close(this%ncid) end if end if call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) call system_clock(count=sub_end) this%close_file_time = sub_end-sub_start end subroutine @@ -319,21 +535,37 @@ subroutine open_file(this) create_mode = IOR(create_mode,NF90_SHARE) create_mode = IOR(create_mode,NF90_MPIIO) call MPI_INFO_CREATE(info,status) + _VERIFY(status) call MPI_INFO_SET(info,"cb_buffer_size","16777216",status) + _VERIFY(status) call MPI_INFO_SET(info,"romio_cb_write","enable",status) + _VERIFY(status) if (this%extra_info) then call MPI_INFO_SET(info,"IBM_largeblock_io","true",status) + _VERIFY(status) call MPI_INFO_SET(info,"striping_unit","4194304",status) + _VERIFY(status) end if if (this%readers_comm /= MPI_COMM_NULL) then if (this%split_file) then call MPI_COMM_RANK(this%readers_comm,writer_rank,status) + _VERIFY(status) write(fc,'(I0.3)')writer_rank fname = "checkpoint_"//fc//".nc4" status = nf90_open(fname,ior(NF90_NETCDF4,NF90_CLOBBER), this%ncid) + if (status /= NF90_NOERR) then + write(*,*) "Error opening file ",fname + call MPI_Abort(MPI_COMM_WORLD,rc,status) + _VERIFY(status) + end if else fname = "checkpoint.nc4" status = nf90_open(fname,create_mode, this%ncid, comm=this%readers_comm, info=info) + if (status /= NF90_NOERR) then + write(*,*) "Error opening file ",fname + call MPI_Abort(MPI_COMM_WORLD,rc,status) + _VERIFY(status) + end if end if end if else @@ -347,6 +579,7 @@ subroutine open_file(this) end if end if call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) call system_clock(count=sub_end) this%open_file_time = sub_end-sub_start end subroutine @@ -354,13 +587,15 @@ subroutine open_file(this) subroutine read_file(this) class(test_support), intent(inout) :: this - integer :: status,i,l + integer :: status,i,l,rc integer(kind=INT64) :: sub_start,sub_end call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) call system_clock(count=sub_start) call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) do i=1,this%num_arrays if (this%scatter_3d) then call this%read_variable(this%bundle(i)%field_name,this%bundle(i)%field) @@ -371,10 +606,13 @@ subroutine read_file(this) end if enddo call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) call system_clock(count=sub_end) call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) this%read_3d_time = sub_end-sub_start call MPI_BARRIER(MPI_COMM_WORLD,status) + _VERIFY(status) end subroutine subroutine read_variable(this,var_name,local_var) @@ -387,7 +625,7 @@ subroutine read_variable(this,var_name,local_var) integer :: start(3), cnt(3) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) - integer :: im_world,jm_world,varid + integer :: im_world,jm_world,varid,rc real, allocatable :: var(:,:,:) integer(kind=INT64) :: start_time,end_time,count_rate,lev,start_mpi,end_mpi real(kind=REAL64) :: io_time @@ -398,11 +636,15 @@ subroutine read_variable(this,var_name,local_var) ndes_x = size(this%in) call mpi_comm_rank(this%ycomm,myrow,status) + _VERIFY(status) call mpi_comm_rank(this%scatter_comm,myiorank,status) + _VERIFY(status) call mpi_comm_size(this%scatter_comm,num_io_rows,status) + _VERIFY(status) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) + _VERIFY(status) if(myiorank==0) then do j=1,num_io_rows @@ -437,7 +679,9 @@ subroutine read_variable(this,var_name,local_var) if (this%do_reads) then if (this%netcdf_reads) then status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + _VERIFY(status) status = nf90_get_var(this%ncid,varid,var,start,cnt) + _VERIFY(status) else write(this%ncid)var end if @@ -478,9 +722,13 @@ subroutine read_variable(this,var_name,local_var) call system_clock(count=start_mpi) call mpi_scatterv( buf, sendcounts, displs, MPI_REAL, local_var, size(local_var), MPI_REAL, & 0, this%scatter_comm, status ) + _VERIFY(status) call system_clock(count=end_mpi) this%time_mpi = this%mpi_time + (end_mpi - start_mpi) - if (this%read_barrier) call MPI_Barrier(MPI_COMM_WORLD,status) + if (this%read_barrier) then + call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) + end if deallocate(buf, stat=status) deallocate (sendcounts, displs, stat=status) @@ -498,7 +746,7 @@ subroutine read_level(this,var_name,local_var,z_index) integer :: start(3), cnt(3) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) - integer :: im_world,jm_world,varid + integer :: im_world,jm_world,varid,rc real, allocatable :: var(:,:) integer(kind=INT64) :: start_time,end_time,count_rate,start_mpi,end_mpi real(kind=REAL64) :: io_time @@ -509,11 +757,15 @@ subroutine read_level(this,var_name,local_var,z_index) ndes_x = size(this%in) call mpi_comm_rank(this%ycomm,myrow,status) + _VERIFY(status) call mpi_comm_rank(this%scatter_comm,myiorank,status) + _VERIFY(status) call mpi_comm_size(this%scatter_comm,num_io_rows,status) + _VERIFY(status) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) + _VERIFY(status) if(myiorank==0) then do j=1,num_io_rows @@ -531,7 +783,9 @@ subroutine read_level(this,var_name,local_var,z_index) jsize=jsize + (this%jn(myrow+j) - this%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) + _VERIFY(status) allocate(buf(IM_WORLD*jsize), stat=status) + _VERIFY(status) start(1) = 1 if (this%split_file) then @@ -548,7 +802,9 @@ subroutine read_level(this,var_name,local_var,z_index) if (this%do_reads) then if (this%netcdf_reads) then status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + _VERIFY(status) status = nf90_get_var(this%ncid,varid,var,start,cnt) + _VERIFY(status) else read(this%ncid)var end if @@ -585,9 +841,10 @@ subroutine read_level(this,var_name,local_var,z_index) allocate(buf(0), stat=status) endif - call system_clock(count=start_mpi) + call system_clock(count=start_mpi) call mpi_scatterv( buf, sendcounts, displs, MPI_REAL, local_var, size(local_var), MPI_REAL, & 0, this%scatter_comm, status ) + _VERIFY(status) call system_clock(count=end_mpi) this%mpi_time = this%mpi_time + (end_mpi - start_mpi) if (this%read_barrier) call MPI_Barrier(MPI_COMM_WORLD,status) @@ -599,11 +856,13 @@ subroutine read_level(this,var_name,local_var,z_index) end module +#define I_AM_MAIN #include "MAPL_ErrLog.h" program checkpoint_tester use ESMF use MPI use NetCDF + use fargparse use mapl_restart_support_mod use, intrinsic :: iso_fortran_env, only: REAL64, INT64 implicit NONE @@ -618,24 +877,47 @@ program checkpoint_tester real(kind=REAL64) :: mean_throughput, mean_fs_throughput real(kind=REAL64) :: std_throughput, std_fs_throughput + type(StringUnlimitedMap) :: options + type(cli_options) :: cli + call system_clock(count=start_app,count_rate=count_rate) call MPI_Init(status) + _VERIFY(status) call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) + _VERIFY(status) support%my_rank = rank call MPI_Comm_Size(MPI_COMM_WORLD,comm_size,status) + _VERIFY(status) call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD) call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) + + options = parse_arguments() + + call get_cli_options(options,cli) + + ! if we have it, we load the configuration file + if (allocated(cli%config_file)) then + if (rank == 0) write(*,*) "Using configuration file ",cli%config_file + if (rank == 0) write(*,*) "NOTE: This overrides any other command line options" + call support%set_parameters_by_config(cli%config_file) + else + call support%set_parameters_by_cli(cli) + end if - call support%set_parameters("restart_benchmark.rc") call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call support%create_arrays() call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call support%create_communicators() call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) allocate(total_throughput(support%n_trials)) allocate(all_proc_throughput(support%n_trials)) @@ -645,14 +927,18 @@ program checkpoint_tester call system_clock(count=start_read) call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call support%open_file() call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call support%read_file() call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call support%close_file() call MPI_Barrier(MPI_COMM_WORLD,status) + _VERIFY(status) call system_clock(count=end_time) read_time = real(end_time-start_read,kind=REAL64)/real(count_rate,kind=REAL64) @@ -664,10 +950,14 @@ program checkpoint_tester if (support%readers_comm /= MPI_COMM_NULL) then call MPI_COMM_SIZE(support%readers_comm,reader_size,status) + _VERIFY(status) call MPI_COMM_RANK(support%readers_comm,reader_rank,status) + _VERIFY(status) call MPI_AllReduce(support%data_volume,average_volume,1,MPI_DOUBLE_PRECISION,MPI_SUM,support%readers_comm,status) + _VERIFY(status) average_volume = average_volume/real(reader_size,kind=REAL64) call MPI_AllReduce(support%time_reading,average_time,1,MPI_DOUBLE_PRECISION,MPI_SUM,support%readers_comm,status) + _VERIFY(status) average_time = average_time/real(reader_size,kind=REAL64) end if if (rank == 0) then diff --git a/components.yaml b/components.yaml index 4360ab32a56f..3d65a1df9aa4 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.30.1 + tag: v4.32.0 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.51.0 + tag: v3.55.0 develop: develop ecbuild: diff --git a/generic/AbstractComponent.F90 b/generic/AbstractComponent.F90 index 094333e88616..c9db2c74a891 100644 --- a/generic/AbstractComponent.F90 +++ b/generic/AbstractComponent.F90 @@ -1,4 +1,5 @@ module mapl_AbstractComponent + use pFlogger, only: t_Logger => Logger implicit none private @@ -96,7 +97,7 @@ subroutine i_RunChild(this, name, clock, phase, unusable, rc) end subroutine i_RunChild subroutine i_SetLogger(this, logger) - use pfl_logger, only: t_Logger => Logger + import t_Logger import AbstractComponent implicit none class(AbstractComponent), intent(inout) :: this @@ -105,7 +106,7 @@ subroutine i_SetLogger(this, logger) end subroutine i_SetLogger function i_GetLogger(this) result(logger) - use pfl_logger, only: t_Logger => Logger + import t_Logger import AbstractComponent implicit none class(t_Logger), pointer :: logger @@ -113,5 +114,5 @@ function i_GetLogger(this) result(logger) end function i_GetLogger end interface - + end module mapl_AbstractComponent diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 13d2a97122c9..28c371198197 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -351,11 +351,32 @@ module MAPL_GenericMod module procedure MAPL_AddAttributeToFields_I4 end interface + interface + subroutine i_Run(gc, import_state, export_state, clock, rc) + use mapl_KeywordEnforcerMod + use ESMF + implicit none + type(ESMF_GridComp) :: gc + type(ESMF_State):: import_state + type(ESMF_State) :: export_state + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + end subroutine i_Run + end interface + ! ======================================================================= integer, parameter :: LAST_ALARM = 99 + ! The next variable is the lesser of two evils: we need a flag the represents MAPL_CustomRefresh + ! In PR 28xx the assuption was that we could use ESMF_ReadRestart, which has other issues + ! Here we intention us ESMF_Method_None, since it is very unlikely someone in the GEOS/MAPL + ! community will use that flag + + type (ESMF_Method_Flag), public :: MAPL_Method_Refresh = ESMF_Method_None + integer, parameter, public :: MAPL_CustomRefreshPhase = 99 + type MAPL_GenericWrap type(MAPL_MetaComp ), pointer :: MAPLOBJ end type MAPL_GenericWrap @@ -425,7 +446,9 @@ module MAPL_GenericMod integer , pointer :: phase_final(:) => null() integer , pointer :: phase_record(:) => null() integer , pointer :: phase_coldstart(:)=> null() - + integer , pointer :: phase_refresh(:)=> null() + procedure(i_run), public, nopass, pointer :: customRefresh => null() + ! Make accessors? type(ESMF_GridComp) :: RootGC type(ESMF_GridComp) , pointer :: parentGC => null() @@ -2753,6 +2776,7 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXSTR) :: CHILD_NAME character(len=14) :: datestamp ! YYYYMMDD_HHMMz integer :: status + integer :: UserRC integer :: I type (MAPL_MetaComp), pointer :: STATE character(len=1) :: separator @@ -2857,6 +2881,16 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) ! call the actual record method call MAPL_StateRefresh (GC, IMPORT, EXPORT, CLOCK, RC=status ) _VERIFY(status) + +! I_Run + if (associated(STATE%customRefresh)) then + call ESMF_GridCompInitialize(GC, importState=import, & + exportState=export, clock=CLOCK, & + phase=MAPL_CustomRefreshPhase, & + userRC=userRC, _RC) + _VERIFY(userRC) + endif + endif call MAPL_TimerOff(STATE,"GenRefreshMine",_RC) call MAPL_TimerOff(STATE,"GenRefreshTot",_RC) @@ -3982,6 +4016,12 @@ subroutine MAPL_GridCompSetEntryPoint(GC, registeredMethod, usersRoutine, RC) phase = MAPL_AddMethod(META%phase_record, RC=status) else if (registeredMethod == ESMF_METHOD_READRESTART) then phase = MAPL_AddMethod(META%phase_coldstart, RC=status) + else if (registeredMethod == MAPL_METHOD_REFRESH) then + phase = MAPL_AddMethod(META%phase_refresh, RC=status) + meta%customRefresh => usersRoutine + call ESMF_GridCompSetEntryPoint(GC, ESMF_METHOD_INITIALIZE, & + usersRoutine, phase=MAPL_CustomRefreshPhase, _RC) + _RETURN(ESMF_SUCCESS) else _RETURN(ESMF_FAILURE) endif @@ -9805,8 +9845,10 @@ subroutine READIT(WHICH) if (io_rank == 0) then print *,'Using parallel IO for reading file: ',trim(DATAFILE) -#ifdef __NAG_COMPILER_RELEASE +#if defined( __NAG_COMPILER_RELEASE) _FAIL('NAG does not provide ftell. Convert to stream I/O') +#elif defined(__flang__) + _FAIL('flang does not provide ftell. Convert to stream I/O') #else offset = _FTELL(UNIT)+4 #endif diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 146e85d2339a..88d17d5c52a4 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -274,9 +274,10 @@ subroutine run_model(this, comm, unusable, rc) integer :: rank, ierror integer :: status class(Logger), pointer :: lgr - logical :: file_exists + logical :: esmfConfigFileExists type (ESMF_VM) :: vm - character(len=:), allocatable :: esmfComm + character(len=:), allocatable :: esmfComm, esmfConfigFile + integer :: esmfConfigFileLen _UNUSED_DUMMY(unusable) @@ -288,16 +289,41 @@ subroutine run_model(this, comm, unusable, rc) call MPI_COMM_RANK(comm, rank, status) _VERIFY(status) + ! We look to see if the user has set an environment variable for the + ! name of the ESMF configuration file. If they have, we use that. If not, + ! we use the default of "ESMF.rc" for backward compatibility + + ! Step one: default to ESMF.rc + + esmfConfigFile = 'ESMF.rc' + esmfConfigFileLen = len(esmfConfigFile) + + ! Step two: get the length of the environment variable + call get_environment_variable('ESMF_CONFIG_FILE', length=esmfConfigFileLen, status=status) + ! Step three: if the environment variable exists, get the value of the environment variable + if (status == 0) then ! variable exists + ! We need to deallocate so we can reallocate + deallocate(esmfConfigFile) + allocate(character(len = esmfConfigFileLen) :: esmfConfigFile) + call get_environment_variable('ESMF_CONFIG_FILE', value=esmfConfigFile, status=status) + _VERIFY(status) + end if + if (rank == 0) then - inquire(file='ESMF.rc', exist=file_exists) + inquire(file=esmfConfigFile, exist=esmfConfigFileExists) end if - call MPI_BCAST(file_exists, 1, MPI_LOGICAL, 0, comm, status) + call MPI_BCAST(esmfConfigFileExists, 1, MPI_LOGICAL, 0, comm, status) + _VERIFY(status) + call MPI_BCAST(esmfConfigFile, esmfConfigFileLen, MPI_CHARACTER, 0, comm, status) _VERIFY(status) + lgr => logging%get_logger('MAPL') + ! 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, vm=vm, _RC) + if (esmfConfigFileExists) then + call lgr%info("Using ESMF configuration file: %a", esmfConfigFile) + call ESMF_Initialize (configFileName=esmfConfigFile, mpiCommunicator=comm, vm=vm, _RC) else call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, vm=vm, _RC) end if @@ -312,7 +338,6 @@ subroutine run_model(this, comm, unusable, rc) call ESMF_MeshSetMOAB(this%cap_options%with_esmf_moab, rc=status) _VERIFY(status) - lgr => logging%get_logger('MAPL') call lgr%info("Running with MOAB library for ESMF Mesh: %l1", this%cap_options%with_esmf_moab) call this%initialize_cap_gc(rc=status) diff --git a/gridcomps/Cap/MAPL_CapGridComp.F90 b/gridcomps/Cap/MAPL_CapGridComp.F90 index 2ee0e4dca2fd..a868c8bd3914 100644 --- a/gridcomps/Cap/MAPL_CapGridComp.F90 +++ b/gridcomps/Cap/MAPL_CapGridComp.F90 @@ -967,24 +967,22 @@ end function get_CapGridComp_from_gc function get_vec_from_config(config, key, rc) result(vec) + type(StringVector) :: vec type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: key integer, intent(out), optional :: rc logical :: present, tableEnd integer :: status - character(len=ESMF_MAXSTR) :: cap_import - type(StringVector) :: vec + character(len=ESMF_MAXSTR) :: value call ESMF_ConfigFindLabel(config, key//":", isPresent = present, _RC) - cap_import = "" if (present) then - - do while(trim(cap_import) /= "::") + do call ESMF_ConfigNextLine(config, tableEnd=tableEnd, _RC) if (tableEnd) exit - call ESMF_ConfigGetAttribute(config, cap_import, _RC) - if (trim(cap_import) /= "::") call vec%push_back(trim(cap_import)) + call ESMF_ConfigGetAttribute(config, value, _RC) + call vec%push_back(trim(value)) end do end if _RETURN(_SUCCESS) diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 9f4d4dbc6dbe..a8ebfa49eff3 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -36,3 +36,7 @@ set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${t if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) set_source_files_properties(ExtDataGridCompNG.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) endif () + +if(PFUNIT_FOUND) + add_subdirectory(tests EXCLUDE_FROM_ALL) +endif() diff --git a/gridcomps/ExtData2G/ExtDataConfig.F90 b/gridcomps/ExtData2G/ExtDataConfig.F90 index 6ee6f96af98f..c7b13c44c5ec 100644 --- a/gridcomps/ExtData2G/ExtDataConfig.F90 +++ b/gridcomps/ExtData2G/ExtDataConfig.F90 @@ -107,7 +107,7 @@ recursive subroutine new_ExtDataConfig_from_yaml(ext_config,config_file,current_ 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") + _ASSERT(.not.associated(temp_ds),"defined duplicate named collection " // trim(hconfig_key)) single_collection = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC) ds = ExtDataFileStream(single_collection,current_time,_RC) call ext_config%file_stream_map%insert(trim(hconfig_key),ds) diff --git a/gridcomps/ExtData2G/ExtDataUpdatePointer.F90 b/gridcomps/ExtData2G/ExtDataUpdatePointer.F90 index 39ed6270bc5a..6bb45a82fccd 100644 --- a/gridcomps/ExtData2G/ExtDataUpdatePointer.F90 +++ b/gridcomps/ExtData2G/ExtDataUpdatePointer.F90 @@ -11,6 +11,7 @@ module MAPL_ExtDataPointerUpdate private public :: ExtDataPointerUpdate + public :: HEARTBEAT_STRING type :: ExtDataPointerUpdate private @@ -30,9 +31,12 @@ module MAPL_ExtDataPointerUpdate procedure :: is_single_shot procedure :: disable procedure :: get_adjusted_time + procedure :: get_offset end type - contains + character(len=*), parameter :: HEARTBEAT_STRING = 'HEARTBEAT' + +contains function get_adjusted_time(this,time,rc) result(adjusted_time) type(ESMF_Time) :: adjusted_time @@ -45,6 +49,14 @@ function get_adjusted_time(this,time,rc) result(adjusted_time) _RETURN(_SUCCESS) end function + function get_offset(this) result(offset) + type(ESMF_TimeInterval) :: offset + class(ExtDataPointerUpdate), intent(in) :: this + + offset = this%offset + + end function get_offset + subroutine create_from_parameters(this,update_time,update_freq,update_offset,time,clock,rc) class(ExtDataPointerUpdate), intent(inout) :: this character(len=*), intent(in) :: update_time @@ -54,10 +66,15 @@ subroutine create_from_parameters(this,update_time,update_freq,update_offset,tim type(ESMF_Clock), intent(inout) :: clock integer, optional, intent(out) :: rc - integer :: status,int_time,year,month,day,hour,minute,second,neg_index + integer :: status,int_time,year,month,day,hour,minute,second logical :: negative_offset + type(ESMF_TimeInterval) :: timestep + integer :: multiplier + integer :: i, j + logical :: is_heartbeat this%last_checked = time + call ESMF_ClockGet(clock, timestep=timestep, _RC) if (update_freq == "-") then this%single_shot = .true. else if (update_freq /= "PT0S") then @@ -71,22 +88,79 @@ subroutine create_from_parameters(this,update_time,update_freq,update_offset,tim this%last_ring = this%reference_time this%update_freq = string_to_esmf_timeinterval(update_freq,_RC) end if - negative_offset = .false. - if (index(update_offset,"-") > 0) then - negative_offset = .true. - neg_index = index(update_offset,"-") - end if - if (negative_offset) then - this%offset=string_to_esmf_timeinterval(update_offset(neg_index+1:),_RC) - this%offset = -this%offset + i = index(update_offset,"-") + 1 + j = index(update_offset, '+') + 1 + _ASSERT(i==1 .or. j==1, '"+" and "-" cannot both be present in update_offset string.') + negative_offset = i > 1 + if(.not. negative_offset) i = j + call parse_heartbeat_timestring(update_offset(i:), is_heartbeat=is_heartbeat, multiplier=multiplier) + if(is_heartbeat) then + this%offset = multiplier * timestep else - this%offset=string_to_esmf_timeinterval(update_offset,_RC) + this%offset=string_to_esmf_timeinterval(update_offset(i:),_RC) end if + if(negative_offset) this%offset = -this%offset _RETURN(_SUCCESS) _UNUSED_DUMMY(clock) end subroutine create_from_parameters + subroutine parse_heartbeat_timestring(timestring, is_heartbeat, multiplier, rc) + character(len=*), intent(in) :: timestring + logical, intent(out) :: is_heartbeat + integer, intent(out) :: multiplier + character(len=:), allocatable :: found_string + character(len=:), allocatable :: upper + integer, optional, intent(out) :: rc + integer :: status + + multiplier = 1 + upper = ESMF_UtilStringUpperCase(timestring, _RC) + call split_on(upper, HEARTBEAT_STRING, found_string=found_string) + is_heartbeat = len(found_string) > 0 + ! For now, multiplier is simply set to 1. In the future, as needed, the before_string + ! and after_string arguments of split_on can be used to parse for a multiplier. + + end subroutine parse_heartbeat_timestring + + subroutine split_on(string, substring, found_string, before_string, after_string) + character(len=*), intent(in) :: string, substring + character(len=:), allocatable, intent(out) :: found_string + character(len=:), optional, allocatable, intent(out) :: before_string, after_string + integer :: i + + i = index(string, substring) + found_string = '' + if(i > 0) found_string = string(i:i+len(substring)-1) + if(present(before_string)) then + before_string = '' + if(i > 1) before_string = string(:i-1) + end if + if(present(after_string)) then + after_string = '' + if(i + len(substring) <= len(string)) after_string = string(i+len(substring):) + end if + + end subroutine split_on + + function to_upper(s) result(u) + character(len=:), allocatable :: u + character(len=*), intent(in) :: s + character(len=*), parameter :: LOWER = 'qwertyuiopasdfghjklzxcvbnm' + character(len=*), parameter :: UPPER = 'QWERTYUIOPASDFGHJKLZXCVBNM' + character :: ch + integer :: i, j + + u = s + do i = 1, len(u) + ch = u(i:i) + j = index(LOWER, ch) + if(j > 0) ch = UPPER(j:j) + u(i:i) = ch + end do + + end function to_upper + subroutine check_update(this,do_update,use_time,current_time,first_time,rc) class(ExtDataPointerUpdate), intent(inout) :: this logical, intent(out) :: do_update @@ -101,11 +175,11 @@ subroutine check_update(this,do_update,use_time,current_time,first_time,rc) _RETURN(_SUCCESS) end if if (this%simple_alarm_created) then - use_time = current_time+this%offset + use_time = this%get_adjusted_time(current_time) if (first_time) then do_update = .true. this%first_time_updated = .true. - use_time = this%last_ring + this%offset + use_time = this%get_adjusted_time(this%last_ring) else ! normal flow next_ring = this%last_ring @@ -126,7 +200,7 @@ subroutine check_update(this,do_update,use_time,current_time,first_time,rc) do while(next_ring >= current_time) next_ring=next_ring-this%update_freq enddo - use_time = next_ring+this%offset + use_time = this%get_adjusted_time(next_ring) this%last_ring = next_ring do_update = .true. ! alarm never rang during the previous advance, only update the previous update was the first time @@ -134,20 +208,20 @@ subroutine check_update(this,do_update,use_time,current_time,first_time,rc) if (this%first_time_updated) then do_update=.true. this%first_time_updated = .false. - use_time = this%last_ring + this%offset + use_time = this%get_adjusted_time(this%last_ring) end if ! otherwise we land on a time when the alarm would ring and we would update else if (this%last_ring == current_time) then do_update =.true. this%first_time_updated = .false. - use_time = current_time+this%offset + use_time = this%get_adjusted_time(current_time) end if end if end if else do_update = .true. if (this%single_shot) this%disabled = .true. - use_time = current_time+this%offset + use_time = this%get_adjusted_time(current_time) end if this%last_checked = current_time diff --git a/gridcomps/ExtData2G/tests/CMakeLists.txt b/gridcomps/ExtData2G/tests/CMakeLists.txt new file mode 100644 index 000000000000..46fb62b8dfeb --- /dev/null +++ b/gridcomps/ExtData2G/tests/CMakeLists.txt @@ -0,0 +1,20 @@ +set(MODULE_DIRECTORY "${esma_include}/gridcomps/ExtData2G/tests") + +set (test_srcs + Test_ExtDataUpdatePointer.pf + ) + +add_pfunit_ctest(MAPL.ExtData2G.tests + TEST_SOURCES ${test_srcs} + LINK_LIBRARIES MAPL.ExtData2G + ) +set_target_properties(MAPL.ExtData2G.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.ExtData2G.tests PROPERTIES LABELS "ESSENTIAL") + +# With this test, it was shown that if you are building with the GNU Fortran +# compiler and *not* on APPLE, then you need to link with the dl library. +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" AND NOT APPLE) + target_link_libraries(MAPL.ExtData2G.tests ${CMAKE_DL_LIBS}) +endif () + +add_dependencies(build-tests MAPL.ExtData2G.tests) diff --git a/gridcomps/ExtData2G/tests/Test_ExtDataUpdatePointer.pf b/gridcomps/ExtData2G/tests/Test_ExtDataUpdatePointer.pf new file mode 100644 index 000000000000..7abcf9859aea --- /dev/null +++ b/gridcomps/ExtData2G/tests/Test_ExtDataUpdatePointer.pf @@ -0,0 +1,291 @@ +#include "MAPL_Generic.h" +#if defined(I_AM_PFUNIT) +# undef I_AM_PFUNIT +#endif +#define I_AM_PFUNIT + +module Test_ExtDataUpdatePointer + use MAPL_ExtDataPointerUpdate + use funit + use esmf + use MAPL_ExceptionHandling + implicit none + + integer, parameter :: SUCCESS = 0 + integer, parameter :: TIME_STEP_IN_SECONDS = 1 + integer, parameter :: REFERENCE_TIME_FIELDS(*) = [2024, 12, 31, 20, 0, 0] + integer, parameter :: NF = size(REFERENCE_TIME_FIELDS) + integer, parameter :: START_TIME_FIELDS(*) = [2024, 01, 01, 0, 0, 0] + integer, parameter :: DEFAULT_TIME_FIELDS(*) = [REFERENCE_TIME_FIELDS(1:3), 0, 0, 0] + integer, parameter :: UPDATE_TIME_FIELDS(*) = [0, 1, 1, REFERENCE_TIME_FIELDS(4:)] + integer, parameter :: STRLEN = 32 + character(len=*), parameter :: UPDATE_TIMESTRING = 'T20:00:00' + character(len=*), parameter :: UPDATE_FREQ_STRING = '-' + character(len=*), parameter :: ERR_MSG = 'Actual offset does match expected offset.' + type(ESMF_Time) :: start_time + type(ESMF_TimeInterval) :: timestep + type(ESMF_Clock) :: clock + type(ESMF_Time) :: default_time + type(ESMF_TimeInterval) :: time_interval + type(ESMF_Time) :: update_time + type(ESMF_Time) :: reference_time + +contains + + @Before + subroutine set_up() + integer :: status, rc + logical :: uninitialized + + status = SUCCESS + uninitialized = .not. ESMF_IsInitialized(_RC) + if(uninitialized) then + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_GREGORIAN, logKindFlag=ESMF_LOGKIND_NONE, defaultLogKindFlag=ESMF_LOGKIND_NONE, _RC) + end if + call ESMF_TimeIntervalSet(time_interval, _RC) + call ESMF_TimeIntervalSet(timestep, s=TIME_STEP_IN_SECONDS, _RC) + call make_esmf_time(START_TIME_FIELDS, start_time, _RC) + call make_esmf_time(DEFAULT_TIME_FIELDS, default_time, _RC) + call make_esmf_time(UPDATE_TIME_FIELDS, update_time, _RC) + call make_esmf_time(REFERENCE_TIME_FIELDS, reference_time, _RC) + clock = ESMF_ClockCreate(timestep=timestep, startTime=start_time, _RC) + + end subroutine set_up + + @After + subroutine tear_down() + integer :: status, rc + + call ESMF_TimeSet(start_time, _RC) + call ESMF_TimeIntervalSet(timestep, _RC) + call ESMF_ClockDestroy(clock, _RC) + call ESMF_TimeSet(default_time, _RC) + call ESMF_TimeIntervalSet(time_interval, _RC) + call ESMF_TimeSet(update_time, _RC) + call ESMF_TimeSet(reference_time, _RC) + + end subroutine tear_down + + ! Set ESMF_Time using an integer array of datetime fields. + subroutine make_esmf_time(f, datetime, rc) + integer, intent(in) :: f(NF) + type(ESMF_Time), intent(inout) :: datetime + integer, optional, intent(out) :: rc + integer :: status + + status = 0 + call ESMF_TimeSet(datetime, yy=f(1), mm=f(2), dd=f(3), h=f(4), m=f(5), s=f(6), _RC) + _RETURN(_SUCCESS) + + end subroutine make_esmf_time + + ! Put ESMF_Time output args into an integer array. + subroutine get_int_time(datetime, n, rc) + type(ESMF_Time), intent(in) :: datetime + integer, intent(inout) :: n(NF) + integer, optional, intent(out) :: rc + integer :: status + + status = 0 + n = -1 + call ESMF_TimeGet(datetime, yy=n(1), mm=n(2), dd=n(3), h=n(4), m=n(5), s=n(6), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_int_time + + subroutine make_offset_string(offset, offset_string, rc) + integer, intent(in) :: offset + character(len=*), intent(out) :: offset_string + integer, optional, intent(out) :: rc + integer :: status + + write(offset_string, fmt='("PT", I03, "S")', iostat=status) offset + _VERIFY(status) + + end subroutine make_offset_string + + @Test + subroutine test_get_adjusted_time + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=STRLEN) :: offset_string + type(ESMF_TimeInterval) :: offset + integer :: ios + integer, parameter :: OFFSET_IN_SECONDS = 300 + integer :: expected(NF), actual(NF) + + write(offset_string, fmt='("PT", I03, "S")', iostat=ios) OFFSET_IN_SECONDS + _VERIFY(ios) + call ESMF_TimeIntervalSet(offset, s=OFFSET_IN_SECONDS, _RC) + call get_int_time(default_time+offset, expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, offset_string, default_time, clock, _RC) + call get_int_time(ex%get_adjusted_time(default_time), actual, _RC) + @assertEqual(expected, actual, 'Adjusted time does match expected time.') + + end subroutine test_get_adjusted_time + + @Test + subroutine test_create_from_parameters_string_positive() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=STRLEN) :: offset_string + integer, parameter :: OFFSET_IN_SECONDS = 300 + integer :: expected, actual + type(ESMF_TimeInterval) :: interval + + call make_offset_string(OFFSET_IN_SECONDS, offset_string, _RC) + expected = OFFSET_IN_SECONDS + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, offset_string, default_time, clock, _RC) + interval = ex%get_offset() + call ESMF_TimeIntervalGet(interval, s=actual, _RC) + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_create_from_parameters_string_positive + + @Test + subroutine test_create_from_parameters_string_negative() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=STRLEN) :: offset_string + integer, parameter :: OFFSET_IN_SECONDS = 300 + integer :: expected, actual + type(ESMF_TimeInterval) :: interval + + call make_offset_string(OFFSET_IN_SECONDS, offset_string, _RC) + offset_string = '-' // offset_string + expected = -OFFSET_IN_SECONDS + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, offset_string, default_time, clock, _RC) + interval = ex%get_offset() + call ESMF_TimeIntervalGet(interval, s=actual, _RC) + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_create_from_parameters_string_negative + + @Test + subroutine test_create_from_parameters_heartbeat_positive() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=*), parameter :: OFFSET_STRING = HEARTBEAT_STRING + type(ESMF_TimeInterval) :: offset, interval + integer :: expected, actual + + offset = timestep + call ESMF_TimeIntervalGet(offset, s=expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, OFFSET_STRING, default_time, clock, _RC) + interval = ex%get_offset() + call ESMF_TimeIntervalGet(interval, s=actual, _RC) + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_create_from_parameters_heartbeat_positive + + @Test + subroutine test_create_from_parameters_heartbeat_negative() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=*), parameter :: OFFSET_STRING = '-' // HEARTBEAT_STRING + type(ESMF_TimeInterval) :: offset, interval + integer :: expected, actual + + offset = -timestep + call ESMF_TimeIntervalGet(offset, s=expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, OFFSET_STRING, default_time, clock, _RC) + interval = ex%get_offset() + call ESMF_TimeIntervalGet(interval, s=actual, _RC) + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_create_from_parameters_heartbeat_negative + + @Test + subroutine test_compare_positive_string_to_positive_heartbeat() + type(ExtDataPointerUpdate) :: ex_str, ex_hb + integer :: status, rc + type(ESMF_TimeInterval) :: intv_str, intv_hb + integer :: expected, actual + character(len=STRLEN) :: offset_string + + call make_offset_string(TIME_STEP_IN_SECONDS, offset_string, _RC) + + call ex_str%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, offset_string, default_time, clock, _RC) + intv_str = ex_str%get_offset() + call ESMF_TimeIntervalGet(intv_str, s=expected, _RC) + + call ex_hb%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, HEARTBEAT_STRING, default_time, clock, _RC) + intv_hb = ex_hb%get_offset() + call ESMF_TimeIntervalGet(intv_hb, s=actual, _RC) + + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_compare_positive_string_to_positive_heartbeat + + @Test + subroutine test_compare_negative_string_to_negative_heartbeat() + type(ExtDataPointerUpdate) :: ex_str, ex_hb + integer :: status, rc + type(ESMF_TimeInterval) :: intv_str, intv_hb + integer :: expected, actual + character(len=STRLEN) :: offset_string + + call make_offset_string(TIME_STEP_IN_SECONDS, offset_string, _RC) + offset_string = '-' // offset_string + + call ex_str%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, offset_string, default_time, clock, _RC) + intv_str = ex_str%get_offset() + call ESMF_TimeIntervalGet(intv_str, s=expected, _RC) + + call ex_hb%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, '-' // HEARTBEAT_STRING, default_time, clock, _RC) + intv_hb = ex_hb%get_offset() + call ESMF_TimeIntervalGet(intv_hb, s=actual, _RC) + + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_compare_negative_string_to_negative_heartbeat + + @Test + subroutine test_create_from_parameters_heartbeat_positive_explicit() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=*), parameter :: OFFSET_STRING = '+' // HEARTBEAT_STRING + type(ESMF_TimeInterval) :: offset, interval + integer :: expected, actual + + offset = timestep + call ESMF_TimeIntervalGet(offset, s=expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, OFFSET_STRING, default_time, clock, _RC) + interval = ex%get_offset() + call ESMF_TimeIntervalGet(interval, s=actual, _RC) + @assertEqual(expected, actual, ERR_MSG) + + end subroutine test_create_from_parameters_heartbeat_positive_explicit + + @Test + subroutine test_create_from_parameters_heartbeat_positive_negative() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=*), parameter :: OFFSET_STRING = '+-' // HEARTBEAT_STRING + type(ESMF_TimeInterval) :: offset, interval + integer :: expected, actual + + offset = timestep + call ESMF_TimeIntervalGet(offset, s=expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, OFFSET_STRING, default_time, clock, rc=status) + @assertFalse(status == 0, 'An exception should have been thrown.') + + end subroutine test_create_from_parameters_heartbeat_positive_negative + + @Test + subroutine test_create_from_parameters_heartbeat_negative_positive() + type(ExtDataPointerUpdate) :: ex + integer :: status, rc + character(len=*), parameter :: OFFSET_STRING = '-+' // HEARTBEAT_STRING + type(ESMF_TimeInterval) :: offset, interval + integer :: expected, actual + + offset = timestep + call ESMF_TimeIntervalGet(offset, s=expected, _RC) + call ex%create_from_parameters(UPDATE_TIMESTRING, UPDATE_FREQ_STRING, OFFSET_STRING, default_time, clock, rc=status) + @assertFalse(status == 0, 'An exception should have been thrown.') + + end subroutine test_create_from_parameters_heartbeat_negative_positive + +end module Test_ExtDataUpdatePointer diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index cf051b2b66a8..3f692e4b2244 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -15,7 +15,6 @@ module MAPL_EpochSwathMod use MAPL_TimeDataMod use MAPL_VerticalDataMod use MAPL_Constants - use pFIO use MAPL_GriddedIOItemVectorMod use MAPL_GriddedIOItemMod use MAPL_ExceptionHandling diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index dc4e8f258851..4ae3193970c9 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -732,20 +732,11 @@ times_R8_full(1), times_R8_full(nend)) call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) - -! if (jt1==jt2) then -! _FAIL('Epoch Time is too small, empty grid is generated, increase Epoch') -! endif - - !-- shift the zero item to index 1 - zero_obs = .false. if (jt1/=jt2) then zero_obs = .false. - if (jt1==0) jt1=1 else ! at most one obs point exist, set it .true. zero_obs = .true. - !! if (jt1==0) jt1=1 end if ! diff --git a/griddedio/FieldBundleRead.F90 b/griddedio/FieldBundleRead.F90 index 6f0bd2b09c65..352dd414c330 100644 --- a/griddedio/FieldBundleRead.F90 +++ b/griddedio/FieldBundleRead.F90 @@ -48,8 +48,8 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ type(StringVariableMap), pointer :: variables type(Variable), pointer :: this_variable type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: var_name,dim_name - character(len=:), allocatable :: lev_name + character(len=:), pointer :: var_name_ptr,dim_name + character(len=:), allocatable :: lev_name,var_name type(ESMF_Field) :: field type (StringVector), pointer :: dimensions type (StringVectorIterator) :: dim_iter @@ -71,14 +71,15 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ factory => get_factory(file_grid,rc=status) _VERIFY(status) grid_vars = factory%get_file_format_vars() - exclude_vars = grid_vars//",lev,time,lons,lats" + exclude_vars = ","//grid_vars//",lev,time,time_bnds," if (has_vertical_level) lev_size = metadata%get_dimension(trim(lev_name)) variables => metadata%get_variables() var_iter = variables%begin() do while (var_iter /= variables%end()) var_has_levels = .false. - var_name => var_iter%key() + var_name_ptr => var_iter%key() + var_name = ","//var_name_ptr//"," this_variable => var_iter%value() if (has_vertical_level) then @@ -91,20 +92,20 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ enddo end if - if (index(','//trim(exclude_vars)//',',','//trim(var_name)//',') > 0) then + if (index(trim(exclude_vars),trim(var_name)) > 0) then call var_iter%next() cycle end if create_variable = .true. if (present(only_vars)) then - if (index(','//trim(only_vars)//',',','//trim(var_name)//',') < 1) create_variable = .false. + if (index(','//trim(only_vars)//',',trim(var_name)) < 1) create_variable = .false. end if if (create_variable) then if(var_has_levels) then if (grid_size(3) == lev_size) then location=MAPL_VLocationCenter dims = MAPL_DimsHorzVert - field= ESMF_FieldCreate(grid,name=trim(var_name),typekind=ESMF_TYPEKIND_R4, & + field= ESMF_FieldCreate(grid,name=trim(var_name_ptr),typekind=ESMF_TYPEKIND_R4, & ungriddedUbound=[grid_size(3)],ungriddedLBound=[1], rc=status) block real, pointer :: ptr3d(:,:,:) @@ -114,7 +115,7 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ else if (grid_size(3)+1 == lev_size) then location=MAPL_VLocationEdge dims = MAPL_DimsHorzVert - field= ESMF_FieldCreate(grid,name=trim(var_name),typekind=ESMF_TYPEKIND_R4, & + field= ESMF_FieldCreate(grid,name=trim(var_name_ptr),typekind=ESMF_TYPEKIND_R4, & ungriddedUbound=[grid_size(3)],ungriddedLBound=[0], rc=status) block real, pointer :: ptr3d(:,:,:) @@ -125,7 +126,7 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ else location=MAPL_VLocationNone dims = MAPL_DimsHorzOnly - field= ESMF_FieldCreate(grid,name=trim(var_name),typekind=ESMF_TYPEKIND_R4, & + field= ESMF_FieldCreate(grid,name=trim(var_name_ptr),typekind=ESMF_TYPEKIND_R4, & rc=status) block real, pointer :: ptr2d(:,:) @@ -137,8 +138,8 @@ subroutine MAPL_create_bundle_from_metdata_id(bundle,metadata_id,file_name,only_ _VERIFY(status) call ESMF_AttributeSet(field,name='VLOCATION',value=location,rc=status) _VERIFY(status) - units = metadata%get_var_attr_string(var_name,'units',_RC) - long_name = metadata%get_var_attr_string(var_name,'long_name',_RC) + units = metadata%get_var_attr_string(var_name_ptr,'units',_RC) + long_name = metadata%get_var_attr_string(var_name_ptr,'long_name',_RC) call ESMF_AttributeSet(field,name='UNITS',value=units,rc=status) _VERIFY(status) call ESMF_AttributeSet(field,name='LONG_NAME',value=long_name,rc=status) diff --git a/include/unused_dummy.H b/include/unused_dummy.H index 6d7063924148..6ffecb5dfcf1 100644 --- a/include/unused_dummy.H +++ b/include/unused_dummy.H @@ -10,4 +10,8 @@ #ifdef _UNUSED_DUMMY # undef _UNUSED_DUMMY #endif -#define _UNUSED_DUMMY(x) if (.false.) then; associate (q____ => x); end associate; endif +#if defined(__flang__) +# define _UNUSED_DUMMY(x) if (.false.) then; print*, shape(x); endif +#else +# define _UNUSED_DUMMY(x) if (.false.) then; associate (q____ => x); end associate; endif +#endif diff --git a/pfio/AbstractDataReference.F90 b/pfio/AbstractDataReference.F90 index 8c4a06d89597..6ec0b0f235e3 100644 --- a/pfio/AbstractDataReference.F90 +++ b/pfio/AbstractDataReference.F90 @@ -319,7 +319,7 @@ subroutine fetch_data(this,offset_address,global_shape,offset_start, rc) case default _FAIL("dimension not supported yet") end select - + _RETURN(_SUCCESS) end subroutine fetch_data integer function get_length_base(this) result(length) diff --git a/pfio/AbstractServer.F90 b/pfio/AbstractServer.F90 index d93911f302b8..519378445683 100644 --- a/pfio/AbstractServer.F90 +++ b/pfio/AbstractServer.F90 @@ -205,7 +205,10 @@ subroutine set_status(this,status) !$omp critical (counter_status) this%status = status + ! llvm-flang has an issue with omp flush of complex data structures +#if !defined(__flang__) !$omp flush (this) +#endif !$omp end critical (counter_status) end subroutine set_status @@ -217,7 +220,10 @@ subroutine update_status(this, rc) !$omp critical (counter_status) this%status = this%status -1 status = this%status + ! llvm-flang has an issue with omp flush of complex data structures +#if !defined(__flang__) !$omp flush (this) +#endif !$omp end critical (counter_status) if (status /= 0) then _RETURN(_SUCCESS) @@ -290,7 +296,10 @@ subroutine set_AllBacklogIsEmpty(this,status) !$omp critical (backlog_status) this%all_backlog_is_empty = status + ! llvm-flang has an issue with omp flush of complex data structures +#if !defined(__flang__) !$omp flush (this) +#endif !$omp end critical (backlog_status) end subroutine set_AllBacklogIsEmpty diff --git a/pfio/ArrayReference.F90 b/pfio/ArrayReference.F90 index 67a9635ea132..5289c8b74f36 100644 --- a/pfio/ArrayReference.F90 +++ b/pfio/ArrayReference.F90 @@ -87,7 +87,7 @@ function new_ArrayReference_1d(array, rc) result(reference) reference%shape = shape(array) _RETURN(_SUCCESS) - + end function new_ArrayReference_1d function new_ArrayReference_2d(array, rc) result(reference) @@ -151,7 +151,7 @@ function new_ArrayReference_3d(array, rc) result(reference) reference%shape = shape(array) _RETURN(_SUCCESS) - + end function new_ArrayReference_3d @@ -167,16 +167,32 @@ function new_ArrayReference_4d(array, rc) result(reference) select type (array) type is (real(kind=REAL32)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_REAL32 type is (real(kind=REAL64)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_REAL64 type is (integer(kind=INT32)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_INT32 type is (integer(kind=INT64)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_INT64 class default _FAIL( "ArrayRef does not support this type") @@ -184,7 +200,7 @@ function new_ArrayReference_4d(array, rc) result(reference) reference%shape = shape(array) _RETURN(_SUCCESS) - + end function new_ArrayReference_4d function new_ArrayReference_5d(array, rc) result(reference) @@ -199,16 +215,32 @@ function new_ArrayReference_5d(array, rc) result(reference) select type (array) type is (real(kind=REAL32)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_REAL32 type is (real(kind=REAL64)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_REAL64 type is (integer(kind=INT32)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_INT32 type is (integer(kind=INT64)) +#if defined(ODD_IFX_BUG) + if (has_address) reference%base_address = c_loc(array(1,1,1,1,1)) +#else if (has_address) reference%base_address = c_loc(array) +#endif reference%type_kind = pFIO_INT64 class default _FAIL( "ArrayRef does not support this type") @@ -217,7 +249,7 @@ function new_ArrayReference_5d(array, rc) result(reference) reference%shape = shape(array) _RETURN(_SUCCESS) - + end function new_ArrayReference_5d integer function type_kind(element, rc) diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 3c6b826eb4f3..178695eb74ab 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -1,12 +1,12 @@ esma_set_this (OVERRIDE MAPL.pfio) -if(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 20) - if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER 17) - add_definitions(-D__ifort_18) - endif() - endif() -endif() +# This is a workaround for a current ifx bug +# Technically, this bug is only due to a bug between +# ifx, OpenMP, and ArrayReference.F90, but in CMake land, it +# is hard to remove OpenMP flags for a *single* file. +if (CMAKE_Fortran_COMPILER_ID STREQUAL "IntelLLVM") + set_source_files_properties(ArrayReference.F90 PROPERTIES COMPILE_DEFINITIONS ODD_IFX_BUG) +endif () set (srcs # pFIO Files @@ -91,6 +91,26 @@ set (srcs StringVectorUtil.F90 ) +if (BUILD_WITH_PFLOGGER) + find_package (PFLOGGER REQUIRED) +endif () + +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.profiler NetCDF::NetCDF_Fortran NetCDF::NetCDF_C TYPE ${MAPL_LIBRARY_TYPE}) + +target_link_libraries (${this} PUBLIC GFTL::gftl-v2 GFTL_SHARED::gftl-shared-v2 PFLOGGER::pflogger PRIVATE MPI::MPI_Fortran OpenMP::OpenMP_Fortran) +target_include_directories (${this} PUBLIC + $) + +set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) +# Kludge for OSX security and DYLD_LIBRARY_PATH ... +foreach(dir ${OSX_EXTRA_LIBRARY_PATH}) + target_link_libraries(${this} PRIVATE "-Xlinker -rpath -Xlinker ${dir}") +endforeach() + +if (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) + target_compile_definitions(${this} PRIVATE SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) +endif () + ############################################################### # Check to see if quantize capability is present in netcdf-c. # ############################################################### @@ -109,7 +129,7 @@ check_c_source_compiles(" NETCDF_HAS_QUANTIZE) if (NETCDF_HAS_QUANTIZE) message(STATUS "netCDF has quantize capability") - add_definitions(-DNF_HAS_QUANTIZE) + target_compile_definitions(${this} PRIVATE NF_HAS_QUANTIZE) else () message(STATUS "netCDF does not have quantize capability") endif () @@ -128,33 +148,23 @@ check_c_source_compiles(" } " NETCDF_HAS_ZSTD) + +# NOTE: Even if the check above succeeds, zstandard is *not* +# possible with Baselibs (builds HDF5, netCDF as static) +# so we want to check for Baselibs first. + +if (Baselibs_FOUND) + message(STATUS "Baselibs found, zstandard capability not possible") + set(NETCDF_HAS_ZSTD FALSE CACHE BOOL "netCDF has zstandard capability" FORCE) +endif () + if (NETCDF_HAS_ZSTD) message(STATUS "netCDF has zstandard capability") - add_definitions(-DNF_HAS_ZSTD) + target_compile_definitions(${this} PRIVATE NF_HAS_ZSTD) else () message(STATUS "netCDF does not have zstandard capability") endif () -if (BUILD_WITH_PFLOGGER) - find_package (PFLOGGER REQUIRED) -endif () - -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.profiler NetCDF::NetCDF_Fortran NetCDF::NetCDF_C TYPE ${MAPL_LIBRARY_TYPE}) - -target_link_libraries (${this} PUBLIC GFTL::gftl-v2 GFTL_SHARED::gftl-shared-v2 PFLOGGER::pflogger PRIVATE MPI::MPI_Fortran OpenMP::OpenMP_Fortran) -target_include_directories (${this} PUBLIC - $) - -set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) -# Kludge for OSX security and DYLD_LIBRARY_PATH ... -foreach(dir ${OSX_EXTRA_LIBRARY_PATH}) - target_link_libraries(${this} PRIVATE "-Xlinker -rpath -Xlinker ${dir}") -endforeach() - -if (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) - target_compile_definitions(${this} PRIVATE SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) -endif () - ecbuild_add_executable ( TARGET pfio_open_close.x SOURCES pfio_open_close.F90 diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index bf2d61cd52bf..99874f729d69 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -1154,7 +1154,7 @@ subroutine get_DataFromMem( this, multi_data_read, rc) offset_address = c_loc(i_ptr(offset+1)) - call mem_data_reference%fetch_data(offset_address,q%global_count,q%start-q%global_start+1) + call mem_data_reference%fetch_data(offset_address,q%global_count,q%start-q%global_start+1, _RC) call this%insert_RequestHandle(q%request_id, & & connection%put(q%request_id, mem_data_reference)) diff --git a/pfio/Variable.F90 b/pfio/Variable.F90 index 84958a172945..001e22a92968 100644 --- a/pfio/Variable.F90 +++ b/pfio/Variable.F90 @@ -12,6 +12,7 @@ module pFIO_VariableMod use pFIO_AttributeMod use pFIO_StringAttributeMapMod use pFIO_StringAttributeMapUtilMod + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 implicit none private @@ -40,6 +41,11 @@ module pFIO_VariableMod procedure :: get_const_value procedure :: get_attribute + procedure :: get_attribute_string + procedure :: get_attribute_int32 + procedure :: get_attribute_int64 + procedure :: get_attribute_real32 + procedure :: get_attribute_real64 generic :: add_attribute => add_attribute_0d generic :: add_attribute => add_attribute_1d procedure :: add_attribute_0d @@ -258,6 +264,133 @@ function get_attribute(this, attr_name, rc) result(attr) _RETURN(_SUCCESS) end function get_attribute + function get_attribute_string(this, attr_name, rc) result(attr_string) + character(len=:), allocatable :: attr_string + class (Variable), target, intent(in) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no such attribute "//attr_name) + attr_val => attr%get_value() + select type(attr_val) + type is(character(*)) + attr_string = attr_val + class default + _FAIL('unsupported subclass (not string) of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_string + + function get_attribute_real32(this,attr_name,rc) result(attr_real32) + real(REAL32) :: attr_real32 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + real(REAL32) :: tmp(1) + real(REAL64) :: tmpd(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(real(kind=REAL32)) + tmp = attr_val + attr_real32 = tmp(1) + type is(real(kind=REAL64)) + tmpd = attr_val + attr_real32 = REAL(tmpd(1)) + class default + _FAIL('unsupported subclass (not real32) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_real32 + + function get_attribute_real64(this,attr_name,rc) result(attr_real64) + real(REAL64) :: attr_real64 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + real(REAL64) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no such attribute "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(real(kind=REAL64)) + tmp = attr_val + attr_real64 = tmp(1) + class default + _FAIL('unsupported subclass (not real64) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_real64 + + function get_attribute_int32(this,attr_name,rc) result(attr_int32) + integer(INT32) :: attr_int32 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer(INT32) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(integer(kind=INT32)) + tmp = attr_val + attr_int32 = tmp(1) + class default + _FAIL('unsupported subclass (not int32) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_int32 + + function get_attribute_int64(this,attr_name,rc) result(attr_int64) + integer(INT64) :: attr_int64 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer(INT64) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(integer(kind=INT64)) + tmp = attr_val + attr_int64 = tmp(1) + class default + _FAIL('unsupported subclass (not int64) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_int64 + subroutine add_const_value(this, const_value, rc) class (Variable), target, intent(inout) :: this type (UnlimitedEntity), intent(in) :: const_value