diff --git a/.circleci/config.yml b/.circleci/config.yml index 2321066747f7..c8f8f3ee4be6 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -211,7 +211,7 @@ workflows: baselibs_version: *baselibs_version repo: GEOSadas checkout_fixture: true - #fixture_branch: feature/mathomp4/ignore-heldsuarez + fixture_branch: feature/mathomp4/mapldevelop checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 8b1e9c3de350..467e64ea8ce6 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -30,7 +30,7 @@ jobs: OMPI_MCA_btl_vader_single_copy_mechanism: none steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.11.0 + uses: styfle/cancel-workflow-action@0.12.0 with: access_token: ${{ github.token }} - name: Checkout @@ -86,7 +86,7 @@ jobs: #password: ${{ secrets.DOCKERHUB_TOKEN }} steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.11.0 + uses: styfle/cancel-workflow-action@0.12.0 with: access_token: ${{ github.token }} - name: Checkout diff --git a/CHANGELOG.md b/CHANGELOG.md index da96d57431ce..bfada66bd2c4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,32 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.42.0] - 2023-10-27 + +### Added + +- Various workarounds for building MAPL with MPICH + - Non-support for `C_PTR` in `MPI_Alloc_Mem` ((MPICH Issue #6691)[https://github.com/pmodels/mpich/issues/6691]) + - Non-support for `ierror` keyword arguments with `use mpi` ((MPICH Issue #6693)[https://github.com/pmodels/mpich/issues/6693]) +- Add new benchmark to simulation writing a cubed-sphere file using various tunable strategies + +### Changed + +- Modified fpp macro `_UNUSED_DUMMY(x)` to use ASSOCIATE instead of PRINT. With this change it can be used in PURE procedures. +- Make error handling in Plain_netCDF_Time consistent with MAPL standard error handling +- Extend unit tests for FileSystemUtilities. +- Updated handling of NetCDF time values +- Update `components.yaml` + - ESMA_cmake v3.36.0 (Support for SLES15 at NCCS, support for Intel 2021.10) + - ESMA_env v4.20.5 (Support for SLES15 at NCCS) + +### Fixed + +- Introduced workaround for Intel 2021.10 bug in generic layer. +- Updated write_by_oserver logic so that the decision to write by the oserver is based on whether the output server client is passed in +- Updated CI GEOSadas build to use special branch (as stock ADAS at the moment is too far behind GEOSgcm main) +- Fix incorrect History print during runtime + ## [2.41.2] - 2023-10-27 ### Fixed @@ -163,6 +189,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Suppress some common warnings with Intel Debug - Make the GEOSadas CI build separate as it often fails due to race conditions in GSI - Update CI to use BCs v11.1.0 and Baselibs 7.14.0 +- Update MAPL_NetCDF public subroutine returns and support for real time - Updates to support building MAPL with spack instead of Baselibs - Add `FindESMF.cmake` file to `cmake` directory (as it can't easily be found via spack) - Move `CMAKE_MODULE_PATH` append statement up to find `FindESMF.cmake` before we `find_package(ESMF)` diff --git a/CMakeLists.txt b/CMakeLists.txt index e210d602ffe5..d14733c3bcaf 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.41.2 + VERSION 2.42.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui @@ -211,6 +211,16 @@ add_definitions(-Dsys${CMAKE_SYSTEM_NAME}) add_subdirectory (MAPL_cfio MAPL_cfio_r4) add_subdirectory (MAPL_cfio MAPL_cfio_r8) +# This tests for various capabilities of the compiler +# We mainly use it for MPICH issues +include(CheckCompilerCapabilities) + +# 1. The first workaround is in pfio for https://github.com/pmodels/mpich/issues/6691 +# 2. Below is to workaround https://github.com/pmodels/mpich/issues/6693 +if(SUPPORT_FOR_MPI_IERROR_KEYWORD) + add_compile_definitions(SUPPORT_FOR_MPI_IERROR_KEYWORD) +endif() + add_subdirectory (pfio) add_subdirectory (profiler) add_subdirectory (generic) diff --git a/MAPL_cfio/ESMF_CFIOMod.F90 b/MAPL_cfio/ESMF_CFIOMod.F90 index 1429f0b86060..a6abe180a048 100644 --- a/MAPL_cfio/ESMF_CFIOMod.F90 +++ b/MAPL_cfio/ESMF_CFIOMod.F90 @@ -515,12 +515,16 @@ subroutine ESMF_CFIOVarWrite3D_(cfio, vName, field, date, curTime, & integer :: rtcode integer :: myDate, myCurTime character(len=16) :: format +#if defined(HDFEOS) logical :: do_comp, do_chunk - +#endif +#if defined(HDFEOS) do_chunk = .false. do_comp = .false. if ( present(doComp) ) do_comp = doComp if ( present(doChunk) ) do_chunk = doChunk +#endif + if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) @@ -562,7 +566,11 @@ subroutine ESMF_CFIOVarWrite3D_(cfio, vName, field, date, curTime, & print *, "CFIO%FORMAT is not known" if (present(rc)) rc = -54 return - end subroutine ESMF_CFIOVarWrite3D_ +#if !defined(HDFEOS) + associate(q => dochunk); end associate + associate(q => docomp); end associate +#endif + end subroutine ESMF_CFIOVarWrite3D_ !------------------------------------------------------------------------------ !> @@ -618,13 +626,15 @@ subroutine ESMF_CFIOVarWrite2D_(cfio, vName, field, date, curTime, & integer :: rtcode integer :: myDate, myCurTime character(len=16) :: format +#if defined(HDFEOS) logical :: do_comp, do_chunk - +#endif +#if defined(HDFEOS) do_chunk = .false. do_comp = .false. if ( present(doComp) ) do_comp = doComp if ( present(doChunk) ) do_chunk = doChunk - +#endif if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) @@ -666,7 +676,11 @@ subroutine ESMF_CFIOVarWrite2D_(cfio, vName, field, date, curTime, & print *, "CFIO%FORMAT is not known" if (present(rc)) rc = -54 return - end subroutine ESMF_CFIOVarWrite2D_ +#if !defined(HDFEOS) + associate(q => dochunk); end associate + associate(q => docomp); end associate +#endif + end subroutine ESMF_CFIOVarWrite2D_ !------------------------------------------------------------------------------ !> ! `ESMF_CFIOVarWrite1D_` -- Write a variable to a output file diff --git a/README.md b/README.md index b678f1ee1666..0d35086d038f 100644 --- a/README.md +++ b/README.md @@ -33,6 +33,7 @@ MAPL also has a variety of other auxiliary directories: 9. **docs** - documentation ## Using MAPL + You can find simple examples on how to use MAPL components in ESMF applications at: [MAPL Tutorial](https://github.com/GEOS-ESM/MAPL/blob/main/docs/tutorial/README.md) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 8becb4702fb4..dcc86a07611b 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -155,10 +155,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) integer :: status character(len=ESMF_MAXSTR) :: comp_name - !real(REAL64) :: ptop, pint - !real(REAL64), allocatable :: ak(:),bk(:) integer :: nrows, ncolumn,i - !integer :: ls type(ESMF_Grid) :: grid type(ESMF_Time) :: currTime type(SyntheticFieldSupportWrapper) :: synthWrap @@ -198,13 +195,6 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_GridCreate(GC, _RC) call ESMF_GridCompGet(GC, grid=grid, _RC) call set_locstream(_RC) - !allocate(ak(lm+1),stat=status) - !allocate(bk(lm+1),stat=status) - !call set_eta(lm,ls,ptop,pint,ak,bk) - !call ESMF_AttributeSet(grid,name='GridAK', itemCount=LM+1, & - !valuelist=ak,_RC) - !call ESMF_AttributeSet(grid,name='GridBK', itemCount=LM+1, & - !valuelist=bk,_RC) call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, clock, _RC) call ForceAllocation(Export,_RC) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 95edd9be0d81..a08dacd1250a 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -55,6 +55,7 @@ set (srcs MAPL_Resource.F90 MAPL_XYGridFactory.F90 MAPL_NetCDF.F90 Plain_netCDF_Time.F90 + MAPL_DateTime_Parsing_ESMF.F90 # Orphaned program: should not be in this library. # tstqsat.F90 ) diff --git a/base/ESMFL_Mod.F90 b/base/ESMFL_Mod.F90 index 2409bb558d23..40498af3648d 100644 --- a/base/ESMFL_Mod.F90 +++ b/base/ESMFL_Mod.F90 @@ -1981,7 +1981,7 @@ subroutine Bundle_Prep_ (srcBUN, dstBUN, only_vars) ! locals - type(ESMF_Array) :: srcArr, dstArr + type(ESMF_Array) :: srcArr type(ESMF_Field) :: srcFld, dstFld integer :: rank integer :: sCPD(3), dCPD(3) ! src and dst counts per dimension (local) @@ -3137,6 +3137,9 @@ subroutine stats_ (lu,mx,my,k,a1,& endif + _UNUSED_DUMMY(ATYPE) + _UNUSED_DUMMY(HTYPE) + _UNUSED_DUMMY(INC) end subroutine stats_ end subroutine BundleDiff diff --git a/base/HorizontalFluxRegridder.F90 b/base/HorizontalFluxRegridder.F90 index 0cb8fadc79f2..44e2594dc51f 100644 --- a/base/HorizontalFluxRegridder.F90 +++ b/base/HorizontalFluxRegridder.F90 @@ -61,7 +61,6 @@ end function supports subroutine initialize_subclass(this, unusable, rc) use MAPL_KeywordEnforcerMod use MAPL_RegridderSpec - use MAPL_BaseMod, only: MAPL_grid_interior class (HorizontalFluxRegridder), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc diff --git a/base/MAPL_DateTime_Parsing_ESMF.F90 b/base/MAPL_DateTime_Parsing_ESMF.F90 new file mode 100644 index 000000000000..5491b6702159 --- /dev/null +++ b/base/MAPL_DateTime_Parsing_ESMF.F90 @@ -0,0 +1,75 @@ +#include "MAPL_Exceptions.h" +#include "MAPL_ErrLog.h" +module MAPL_DateTime_Parsing_ESMF + use MAPL_KeywordEnforcerMod + use MAPL_ExceptionHandling + use MAPL_DateTime_Parsing + use ESMF + + implicit none + + public :: set_ESMF_TimeInterval, set_ESMF_Time_from_ISO8601 + + interface set_ESMF_TimeInterval + module procedure :: set_ESMF_TimeInterval_from_datetime_duration + end interface set_ESMF_TimeInterval + +contains + + subroutine set_ESMF_TimeInterval_from_datetime_duration(interval, duration, rc) + type(ESMF_TimeInterval), intent(inout) :: interval + class(datetime_duration), intent(in) :: duration + integer, optional, intent(out) :: rc + integer :: status + + ! Get duration(s) from datetime_duration + + ! Set ESMF_TimeInterval + + if(duration % year_is_set()) then + call ESMF_TimeIntervalSet(interval, yy = duration % year, _RC) + end if + + if(duration % month_is_set()) then + call ESMF_TimeIntervalSet(interval, yy = duration % month, _RC) + end if + + if(duration % day_is_set()) then + call ESMF_TimeIntervalSet(interval, yy = duration % day, _RC) + end if + + if(duration % hour_is_real()) then + call ESMF_TimeIntervalSet(interval, h_r8 = duration % hour_real, _RC) + else if(duration % hour_is_set()) then + call ESMF_TimeIntervalSet(interval, h = duration % hour, _RC) + end if + + if(duration % minute_is_real()) then + call ESMF_TimeIntervalSet(interval, m_r8 = duration % minute_real, _RC) + else if(duration % minute_is_set()) then + call ESMF_TimeIntervalSet(interval, m = duration % minute, _RC) + end if + + if(duration % second_is_real()) then + call ESMF_TimeIntervalSet(interval, s_r8 = duration % second_real, _RC) + else if(duration % second_is_set()) then + call ESMF_TimeIntervalSet(interval, s = duration % second, _RC) + end if + + _RETURN(_SUCCESS) + + end subroutine set_ESMF_TimeInterval_from_datetime_duration + + subroutine set_ESMF_Time_from_ISO8601(time, isostring, rc) + type(ESMF_Time), intent(inout) :: time + character(len=*), intent(in) :: isostring + integer, optional, intent(out) :: rc + integer :: status + + call ESMF_TimeSet(time, isostring, _RC) + + _RETURN(_SUCCESS) + + end subroutine set_ESMF_Time_from_ISO8601 + +end module MAPL_DateTime_Parsing_ESMF diff --git a/base/MAPL_ISO8601_DateTime_ESMF.F90 b/base/MAPL_ISO8601_DateTime_ESMF.F90 index 11e91b0d97e0..891147caf030 100644 --- a/base/MAPL_ISO8601_DateTime_ESMF.F90 +++ b/base/MAPL_ISO8601_DateTime_ESMF.F90 @@ -7,6 +7,7 @@ module MAPL_ISO8601_DateTime_ESMF use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ISO8601_DateTime + use MAPL_DateTime_Parsing use ESMF implicit none diff --git a/base/MAPL_IdentityRegridder.F90 b/base/MAPL_IdentityRegridder.F90 index 7b70900892dd..3c8224711ab6 100644 --- a/base/MAPL_IdentityRegridder.F90 +++ b/base/MAPL_IdentityRegridder.F90 @@ -10,7 +10,6 @@ module MAPL_IdentityRegridderMod use ESMF use, intrinsic :: iso_fortran_env, only: REAL32 - use, intrinsic :: iso_fortran_env, only: REAL64 implicit none private @@ -165,7 +164,6 @@ end subroutine regrid_vector_3d_real32 subroutine initialize_subclass(this, unusable, rc) use MAPL_KeywordEnforcerMod use MAPL_RegridderSpec - use MAPL_BaseMod, only: MAPL_GridGet class (IdentityRegridder), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc diff --git a/base/MAPL_NetCDF.F90 b/base/MAPL_NetCDF.F90 index 773a297cd2b8..93adc5c2400c 100644 --- a/base/MAPL_NetCDF.F90 +++ b/base/MAPL_NetCDF.F90 @@ -1,8 +1,3 @@ -!wdb todo -!subroutine to convert -!From: integer: array(2) = [ 20010101 010101 (HHMMSS) ] ![ (YYYYMMDD) (HHMMSS) ] -!To: !ESMF_TIME: with gregorian calendar -!And vice versa. #include "MAPL_Exceptions.h" #include "MAPL_ErrLog.h" ! Procedures to convert from NetCDF datetime to ESMF_Time and ESMF_TimeInterval @@ -13,412 +8,119 @@ module MAPL_NetCDF use MAPL_ExceptionHandling use MAPL_KeywordEnforcerMod - use MAPL_DateTime_Parsing - use ESMF + use MAPL_DateTime_Parsing, only: datetime_duration + use MAPL_DateTime_Parsing_ESMF + use MAPL_CF_Time implicit none public :: convert_NetCDF_DateTime_to_ESMF - public :: convert_ESMF_to_NetCDF_DateTime + public :: get_ESMF_Time_from_NetCDF_DateTime private - public :: make_ESMF_TimeInterval - public :: make_NetCDF_DateTime_int_time - public :: make_NetCDF_DateTime_units_string - public :: convert_ESMF_Time_to_NetCDF_DateTimeString - public :: convert_to_integer - public :: convert_NetCDF_DateTimeString_to_ESMF_Time - public :: is_time_unit - public :: is_valid_netcdf_datetime_string - public :: get_shift_sign - public :: split - public :: split_all - public :: lr_trim - character, parameter :: PART_DELIM = ' ' - character, parameter :: ISO_DELIM = 'T' - character, parameter :: DATE_DELIM = '-' - character, parameter :: TIME_DELIM = ':' - character(len=*), parameter :: NETCDF_DATE = '0000' // DATE_DELIM // '00' // DATE_DELIM // '00' - character(len=*), parameter :: NETCDF_TIME = '00' // TIME_DELIM // '00' // TIME_DELIM // '00' - character(len=*), parameter :: NETCDF_DATETIME_FORMAT = NETCDF_DATE // PART_DELIM // NETCDF_TIME - integer, parameter :: LEN_DATE = len(NETCDF_DATE) - integer, parameter :: LEN_TIME = len(NETCDF_TIME) - integer, parameter :: LEN_NETCDF_DATETIME = len(NETCDF_DATETIME_FORMAT) - character(len=*), parameter :: TIME_UNITS(7) = & - [ 'years ', 'months ', 'days ', & - 'hours ', 'minutes ', 'seconds ', 'milliseconds' ] - character, parameter :: SPACE = ' ' - type(ESMF_CalKind_Flag), parameter :: CALKIND_FLAG = ESMF_CALKIND_GREGORIAN - integer, parameter :: MAX_WIDTH = 10 + interface convert_NetCDF_DateTime_to_ESMF + module procedure :: get_ESMF_Time_from_NetCDF_DateTime_integer + module procedure :: get_ESMF_Time_from_NetCDF_DateTime_real + end interface convert_NetCDF_DateTime_to_ESMF + + interface get_ESMF_Time_from_NetCDF_DateTime + module procedure :: get_ESMF_Time_from_NetCDF_DateTime_integer + module procedure :: get_ESMF_Time_from_NetCDF_DateTime_real + end interface get_ESMF_Time_from_NetCDF_DateTime + +! integer, parameter :: MAX_CHARACTER_LENGTH = 64 contains +!=============================================================================== +!========================= HIGH-LEVEL PROCEDURES =========================== + ! Convert NetCDF_DateTime {int_time, units_string} to - ! ESMF time variables {interval, time0, time1} and time unit {tunit} - ! time0 is the start time, and time1 is time0 + interval - subroutine convert_NetCDF_DateTime_to_ESMF(int_time, units_string, & - interval, time0, unusable, time1, tunit, rc) - integer, intent(in) :: int_time + ! ESMF time variables {interval, basetime, time} and time unit {time_unit} + ! basetime is the start time, and time is basetime + interval + subroutine get_ESMF_Time_from_NetCDF_DateTime_integer(duration, units_string, & + interval, basetime, unusable, time, time_unit, rc) + integer, intent(in) :: duration character(len=*), intent(in) :: units_string type(ESMF_TimeInterval), intent(inout) :: interval - type(ESMF_Time), intent(inout) :: time0 + type(ESMF_Time), intent(inout) :: basetime class (KeywordEnforcer), optional, intent(in) :: unusable - type(ESMF_Time), optional, intent(inout) :: time1 - character(len=:), allocatable, optional, intent(out) :: tunit + type(ESMF_Time), optional, intent(inout) :: time + character(len=:), allocatable, optional, intent(out) :: time_unit integer, optional, intent(out) :: rc - character(len=:), allocatable :: tunit_ - character(len=len_trim(units_string)) :: parts(2) - character(len=len_trim(units_string)) :: head - character(len=len_trim(units_string)) :: tail - - integer :: span, factor - integer :: status - - _UNUSED_DUMMY(unusable) - - _ASSERT(int_time >= 0, 'Negative span not supported') - _ASSERT((len(lr_trim(units_string)) > 0), 'units empty') - - ! get time unit, tunit - parts = split(lr_trim(units_string), PART_DELIM) - head = parts(1) - tail = parts(2) - tunit_ = lr_trim(head) - _ASSERT(is_time_unit(tunit_), 'Unrecognized time unit') - if(present(tunit)) tunit = tunit_ - - ! get span - parts = split(lr_trim(tail), PART_DELIM) - head = parts(1) - tail = parts(2) - - factor = get_shift_sign(head) - _ASSERT(factor /= 0, 'Unrecognized preposition') - span = factor * int_time - call convert_NetCDF_DateTimeString_to_ESMF_Time(lr_trim(tail), time0, _RC) - call make_ESMF_TimeInterval(span, tunit_, time0, interval, _RC) - - ! get time1 - if(present(time1)) time1 = time0 + interval - - _RETURN(_SUCCESS) - - end subroutine convert_NetCDF_DateTime_to_ESMF - - ! Convert ESMF time variables to an NetCDF datetime - subroutine convert_ESMF_to_NetCDF_DateTime(tunit, t0, int_time, units_string, unusable, t1, interval, rc) - character(len=*), intent(in) :: tunit - type(ESMF_Time), intent(inout) :: t0 - integer, intent(out) :: int_time - character(len=:), allocatable, intent(out) :: units_string - class (KeywordEnforcer), optional, intent(in) :: unusable - type(ESMF_Time), optional, intent(inout) :: t1 - type(ESMF_TimeInterval), optional, intent(inout) :: interval - integer, optional, intent(out) :: rc - type(ESMF_TimeInterval) :: interval_ + type(CF_Time_Integer) :: cft + type(datetime_duration) :: dt_duration + character(len=MAX_CHARACTER_LENGTH) :: isostring + character(len=MAX_CHARACTER_LENGTH) :: tunit_ integer :: status - + _UNUSED_DUMMY(unusable) - if(present(interval)) then - interval_ = interval - elseif(present(t1)) then - interval_ = t1 - t0 - else - _FAIL( 'Only one input argument present') - end if + _ASSERT((len_trim(adjustl(units_string)) > 0), 'units empty') - call make_NetCDF_DateTime_int_time(interval_, t0, tunit, int_time, _RC) - call make_NetCDF_DateTime_units_string(t0, tunit, units_string, _RC) + cft = CF_Time_Integer(duration, units_string) + call convert_CF_Time_to_datetime_duration(cft, dt_duration, _RC) + call set_ESMF_TimeInterval(interval, dt_duration, _RC) - _RETURN(_SUCCESS) - - end subroutine convert_ESMF_to_NetCDF_DateTime + call extract_ISO8601_from_CF_Time(cft, isostring, _RC) + call set_ESMF_Time_from_ISO8601(basetime, isostring, _RC) - ! Make ESMF_TimeInterval from a span of time, time unit, and start time - subroutine make_ESMF_TimeInterval(span, tunit, t0, interval, unusable, rc) - integer, intent(in) :: span - character(len=*), intent(in) :: tunit - type(ESMF_Time), intent(inout) :: t0 - type(ESMF_TimeInterval), intent(inout) :: interval - class (KeywordEnforcer), optional, intent(in) :: unusable - integer, optional, intent(out) :: rc - integer :: status - - _UNUSED_DUMMY(unusable) + if(present(time)) time = basetime + interval - select case(lr_trim(tunit)) - case('years') - call ESMF_TimeIntervalSet(interval, startTime=t0, yy=span, _RC) - case('months') - call ESMF_TimeIntervalSet(interval, startTime=t0, mm=span, _RC) - case('hours') - call ESMF_TimeIntervalSet(interval, startTime=t0, h=span, _RC) - case('minutes') - call ESMF_TimeIntervalSet(interval, startTime=t0, m=span, _RC) - case('seconds') - call ESMF_TimeIntervalSet(interval, startTime=t0, s=span, _RC) - case default - _FAIL('Unrecognized unit') - end select + if(present(time_unit)) then + call extract_CF_Time_unit(cft, tunit_, _RC) + time_unit = trim(tunit_) + end if _RETURN(_SUCCESS) - end subroutine make_ESMF_TimeInterval + end subroutine get_ESMF_Time_from_NetCDF_DateTime_integer - ! Get time span from NetCDF datetime - subroutine make_NetCDF_DateTime_int_time(interval, t0, tunit, int_time, unusable, rc) + ! Convert NetCDF_DateTime {real_time, units_string} to + ! ESMF time variables {interval, basetime, time} and time unit {time_unit} + ! basetime is the start time, and time is basetime + interval + subroutine get_ESMF_Time_from_NetCDF_DateTime_real(duration, units_string, & + interval, basetime, unusable, time, time_unit, rc) + real(kind=ESMF_KIND_R8), intent(in) :: duration + character(len=*), intent(in) :: units_string type(ESMF_TimeInterval), intent(inout) :: interval - type(ESMF_Time), intent(inout) :: t0 - character(len=*), intent(in) :: tunit - integer, intent(out) :: int_time + type(ESMF_Time), intent(inout) :: basetime class (KeywordEnforcer), optional, intent(in) :: unusable + type(ESMF_Time), optional, intent(inout) :: time + character(len=:), allocatable, optional, intent(out) :: time_unit integer, optional, intent(out) :: rc - integer :: status - - _UNUSED_DUMMY(unusable) - - ! get int_time - select case(lr_trim(tunit)) - case('years') - call ESMF_TimeIntervalGet(interval, t0, yy=int_time, _RC) - case('months') - call ESMF_TimeIntervalGet(interval, t0, mm=int_time, _RC) - case('hours') - call ESMF_TimeIntervalGet(interval, t0, h=int_time, _RC) - case('minutes') - call ESMF_TimeIntervalGet(interval, t0, m=int_time, _RC) - case('seconds') - call ESMF_TimeIntervalGet(interval, t0, s=int_time, _RC) - case default - _FAIL('Unrecognized unit') - end select - - _RETURN(_SUCCESS) - - end subroutine make_NetCDF_DateTime_int_time - ! Make 'units' for NetCDF datetime - subroutine make_NetCDF_DateTime_units_string(t0, tunit, units_string, unusable, rc) - type(ESMF_Time), intent(inout) :: t0 - character(len=*), intent(in) :: tunit - character(len=:), allocatable, intent(out) :: units_string - class (KeywordEnforcer), optional, intent(in) :: unusable - integer, optional, intent(out) :: rc - character(len=*), parameter :: preposition = 'since' - character(len=:), allocatable :: datetime_string + type(CF_Time_Real) :: cft + type(datetime_duration) :: dt_duration + character(len=MAX_CHARACTER_LENGTH) :: isostring + character(len=MAX_CHARACTER_LENGTH) :: tunit_ integer :: status _UNUSED_DUMMY(unusable) - ! make units_string - call convert_ESMF_Time_to_NetCDF_DateTimeString(t0, datetime_string, _RC) - units_string = tunit //SPACE// preposition //SPACE// datetime_string + _ASSERT((len_trim(adjustl(units_string)) > 0), 'units empty') - _RETURN(_SUCCESS) + cft = CF_Time_Real(duration, units_string) + call convert_CF_Time_to_datetime_duration(cft, dt_duration, _RC) + call set_ESMF_TimeInterval(interval, dt_duration, _RC) - end subroutine make_NetCDF_DateTime_units_string + call extract_ISO8601_from_CF_Time(cft, isostring, _RC) + call set_ESMF_Time_from_ISO8601(basetime, isostring, _RC) - ! Convert ESMF_Time to a NetCDF datetime string (start datetime) - subroutine convert_ESMF_Time_to_NetCDF_DateTimeString(esmf_datetime, datetime_string, unusable, rc) - type(ESMF_Time), intent(inout) :: esmf_datetime - character(len=:), allocatable, intent(out) :: datetime_string - class (KeywordEnforcer), optional, intent(in) :: unusable - integer, optional, intent(out) :: rc - - character(len=*), parameter :: ERR_PRE = 'Failed to write string: ' - integer :: yy, mm, dd, h, m, s - character(len=10) :: FMT - character(len=4) :: yy_string - character(len=2) :: mm_string - character(len=2) :: dd_string - character(len=2) :: h_string - character(len=2) :: m_string - character(len=2) :: s_string - character(len=LEN_NETCDF_DATETIME) :: tmp_string - integer :: status, iostatus + if(present(time)) time = basetime + interval - _UNUSED_DUMMY(unusable) - - call ESMF_TimeGet(esmf_datetime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) - - FMT='(BZ, I2.2)' - write(s_string, fmt=FMT, iostat=iostatus) s - _ASSERT(iostatus == 0, ERR_PRE // 'second') - write(m_string, fmt=FMT, iostat=iostatus) m - _ASSERT(iostatus == 0, ERR_PRE // 'minute') - write(h_string, fmt=FMT, iostat=iostatus) h - _ASSERT(iostatus == 0, ERR_PRE // 'hour') - write(dd_string, fmt=FMT, iostat=iostatus) dd - _ASSERT(iostatus == 0, ERR_PRE // 'day') - write(mm_string, fmt=FMT, iostat=iostatus) mm - _ASSERT(iostatus == 0, ERR_PRE // 'month') - FMT='(BZ, I4.4)' - write(yy_string, fmt=FMT, iostat=iostatus) yy - _ASSERT(iostatus == 0, ERR_PRE // 'year') - - tmp_string = yy_string // DATE_DELIM // mm_string // DATE_DELIM // dd_string // PART_DELIM // & - h_string // TIME_DELIM // m_string // TIME_DELIM // s_string - - datetime_string = tmp_string - - _RETURN(_SUCCESS) - - end subroutine convert_ESMF_Time_to_NetCDF_DateTimeString - - ! Convert string representing an integer to the integer - subroutine convert_to_integer(string_in, int_out, rc) - character(len=*), intent(in) :: string_in - integer, intent(out) :: int_out - integer, optional, intent(out) :: rc - integer :: stat - - read(string_in, '(I16)', iostat=stat) int_out - - if(present(rc)) rc = stat - - end subroutine convert_to_integer - - ! Convert NetCDF datetime to ESMF_Time - subroutine convert_NetCDF_DateTimeString_to_ESMF_Time(datetime_string, datetime, unusable, rc) - character(len=*), intent(in) :: datetime_string - type(ESMF_Time), intent(inout) :: datetime - class (KeywordEnforcer), optional, intent(in) :: unusable - integer, optional, intent(out) :: rc - integer :: status - integer :: yy, mm, dd, h, m, s, i, j - character(len=4) :: part - - _UNUSED_DUMMY(unusable) - - _ASSERT(is_valid_netcdf_datetime_string(datetime_string), 'Invalid datetime string') - - i = 1 - j = i + 3 - part = datetime_string(i:j) - call convert_to_integer(part, yy, rc = status) - _ASSERT(status == 0, 'Unable to convert year string') - - i = j + 2 - j = j + 3 - part = datetime_string(i:j) - call convert_to_integer(part, mm, rc = status) - _ASSERT(status == 0, 'Unable to convert month string') - - i = j + 2 - j = j + 3 - part = datetime_string(i:j) - call convert_to_integer(part, dd, rc = status) - _ASSERT(status == 0, 'Unable to convert day string') - - i = j + 2 - j = j + 3 - part = datetime_string(i:j) - call convert_to_integer(part, h, rc = status) - _ASSERT(status == 0, 'Unable to convert hour string') - - i = j + 2 - j = j + 3 - part = datetime_string(i:j) - call convert_to_integer(part, m, rc = status) - _ASSERT(status == 0, 'Unable to convert minute string') - - i = j + 2 - j = j + 3 - part = datetime_string(i:j) - call convert_to_integer(part, s, rc = status) - _ASSERT(status == 0, 'Unable to convert second string') - call ESMF_CalendarSetDefault(CALKIND_FLAG, _RC) - call ESMF_TimeSet(datetime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) + if(present(time_unit)) then + call extract_CF_Time_unit(cft, tunit_, _RC) + time_unit = trim(tunit_) + end if _RETURN(_SUCCESS) - end subroutine convert_NetCDF_DateTimeString_to_ESMF_Time - - function is_valid_netcdf_datetime_string(string) result(tval) - character(len=*), parameter :: DIGITS = '0123456789' - character(len=*), intent(in) :: string - logical :: tval - integer :: i - - tval = .false. - - if(len(string) /= len(NETCDF_DATETIME_FORMAT)) return - - do i=1, len(string) - if(scan(NETCDF_DATETIME_FORMAT(i:i), DIGITS) > 0) then - if(scan(string(i:i), DIGITS) <= 0) return - else - if(string(i:i) /= NETCDF_DATETIME_FORMAT(i:i)) return - end if - end do - - tval = .true. - - end function is_valid_netcdf_datetime_string - - function is_time_unit(tunit) - character(len=*), intent(in) :: tunit - logical :: is_time_unit - integer :: i - - is_time_unit = .TRUE. - do i = 1, size(TIME_UNITS) - if(lr_trim(tunit) == lr_trim(TIME_UNITS(i))) return - end do - is_time_unit = .FALSE. - - end function is_time_unit - - function lr_trim(string) - character(len=*), intent(in) :: string - character(len=:), allocatable :: lr_trim - - lr_trim = trim(adjustl(string)) - - end function lr_trim - - ! Get the sign of integer represening a time span based on preposition - function get_shift_sign(preposition) - character(len=*), intent(in) :: preposition - integer :: get_shift_sign - integer, parameter :: POSITIVE = 1 - get_shift_sign = 0 - if(lr_trim(preposition) == 'since') get_shift_sign = POSITIVE - end function get_shift_sign - - ! Split string at delimiter - function split(string, delimiter) - character(len=*), intent(in) :: string - character(len=*), intent(in) :: delimiter - character(len=len(string)) :: split(2) - integer start - - split = ['', ''] - split(1) = string - start = index(string, delimiter) - if(start < 1) return - split(1) = string(1:(start - 1)) - split(2) = string((start+len(delimiter)):len(string)) - end function split - - ! Split string into all substrings based on delimiter - recursive function split_all(string, delimiter) result(parts) - character(len=*), intent(in) :: string - character(len=*), intent(in) :: delimiter - character(len=:), allocatable :: parts(:) - integer :: start - - start = index(string, delimiter) - - if(start == 0) then - parts = [string] - else - parts = [string(1:(start-1)), split_all(string((start+len(delimiter)):len(string)), delimiter)] - end if + end subroutine get_ESMF_Time_from_NetCDF_DateTime_real - end function split_all +!======================= END HIGH-LEVEL PROCEDURES ========================= +!=============================================================================== end module MAPL_NetCDF diff --git a/base/MAPL_TilingRegridder.F90 b/base/MAPL_TilingRegridder.F90 index da319cbb420e..84a8be3b6df8 100644 --- a/base/MAPL_TilingRegridder.F90 +++ b/base/MAPL_TilingRegridder.F90 @@ -198,8 +198,6 @@ function read_geos_binary(file_name, unusable, rc) result(tile_file) logical :: am_i_root type (ESMF_VM) :: vm - _UNUSED_DUMMY(unusable) - call ESMF_VMGetCurrent(vm, rc=status) _VERIFY(status) call ESMF_VmGet(VM, localPet=deId, petCount=npes, rc=status) @@ -242,6 +240,7 @@ function read_geos_binary(file_name, unusable, rc) result(tile_file) end if _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) contains @@ -285,6 +284,7 @@ subroutine read_tiling_metadata(tiling, unusable, rc) _VERIFY(status) _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end subroutine read_tiling_metadata @@ -297,7 +297,6 @@ subroutine read_tiling_data(n_tiles, tiling, unusable, rc) integer, optional, intent(out) :: rc real(kind=REAL32), pointer :: buffer(:) - integer :: length character(len=*), parameter :: Iam = 'read_tiling_data' integer :: status @@ -340,7 +339,7 @@ subroutine read_tiling_data(n_tiles, tiling, unusable, rc) end if _RETURN(_SUCCESS) - + _UNUSED_DUMMY(unusable) end subroutine read_tiling_data end function read_geos_binary @@ -354,9 +353,7 @@ function read_tempest(file_name, unusable, rc) result(tile_file) character(len=*), parameter :: Iam = 'read_tempest' - _UNUSED_DUMMY(unusable) - _UNUSED_DUMMY(rc) - + call readTileFileNC_file(file_name) tile_file%grid_tiles(1)%i_indices = II_in @@ -365,7 +362,9 @@ function read_tempest(file_name, unusable, rc) result(tile_file) tile_file%grid_tiles(1)%j_indices = JJ_out tile_file%grid_tiles(1)%weights = W - end function read_tempest + _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(rc) + end function read_tempest !-------------------------------------------------------------------------------- ! A single tile file supports regridding in both directions, and is @@ -447,7 +446,7 @@ subroutine find_tile_file(this, file_name, swap, unusable, rc) end if _RETURN(_FAILURE) - + _UNUSED_DUMMY(unusable) contains diff --git a/base/MAPL_TimeMethods.F90 b/base/MAPL_TimeMethods.F90 index e368bf721def..b8e0a12141bb 100644 --- a/base/MAPL_TimeMethods.F90 +++ b/base/MAPL_TimeMethods.F90 @@ -6,7 +6,6 @@ module MAPL_TimeDataMod use pFIO use MAPL_ExceptionHandling use MAPL_ESMFTimeVectorMod - use, intrinsic :: iso_fortran_env, only: REAL64 implicit none private diff --git a/base/NCIO.F90 b/base/NCIO.F90 index dbcdee566033..90394334a0ba 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -19,7 +19,6 @@ module NCIOMod !use MAPL_RangeMod use MAPL_ShmemMod use MAPL_ExceptionHandling - use MAPL_Constants, only: MAPL_RADIANS_TO_DEGREES use netcdf use pFIO !use pFIO_ClientManagerMod @@ -313,6 +312,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients type (ESMF_DistGrid) :: distGrid type (LocalMemReference) :: lMemRef integer :: size_1d + logical :: have_oclients call ESMF_FieldGet(field, grid=grid, rc=status) _VERIFY(STATUS) @@ -321,9 +321,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) _VERIFY(STATUS) - if( arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") - endif + have_oclients = present(oClients) call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) _VERIFY(STATUS) @@ -352,7 +350,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients size_1d = size(var_1d,1) endif - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if( MAPL_AM_I_ROOT()) then lMemRef = LocalMemReference(pFIO_REAL32,[size_1d]) call c_f_pointer(lMemRef%base_address, gvar_1d, shape=[size_1d]) @@ -391,7 +389,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients size_1d = size(vr8_1d,1) endif - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if(MAPL_AM_I_ROOT()) then lMemRef = LocalMemReference(pFIO_REAL64,[size_1d]) call c_f_pointer(lMemRef%base_address, gvr8_1d, shape=[size_1d]) @@ -429,7 +427,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (associated(var_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if(MAPL_AM_I_ROOT()) then lMemRef = LocalMemReference(pFIO_REAL32,[arrdes%im_world, size(var_2d,2)]) call c_f_pointer(lMemRef%base_address, gvar_2d, shape=[arrdes%im_world, size(var_2d,2)]) @@ -463,7 +461,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (associated(vr8_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if( MAPL_AM_I_ROOT() ) then lMemRef = LocalMemReference(pFIO_REAL64,[arrdes%im_world,size(vr8_2d,2)]) call c_f_pointer(lMemRef%base_address, gvr8_2d, shape=[arrdes%im_world,size(vr8_2d,2)]) @@ -498,7 +496,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (associated(var_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if( MAPL_Am_I_Root() ) then lMemRef = LocalMemReference(pFIO_REAL32,[arrdes%im_world, size(var_3d,2), size(var_3d,3)]) call c_f_pointer(lMemRef%base_address, gvar_3d, shape=[arrdes%im_world, size(var_3d,2), size(var_3d,3)]) @@ -537,7 +535,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (associated(vr8_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then if( MAPL_Am_I_Root() ) then lMemRef = LocalMemReference(pFIO_REAL64,[arrdes%im_world,size(vr8_3d,2), size(vr8_3d,3)]) call c_f_pointer(lMemRef%base_address, gvr8_3d, shape=[arrdes%im_world,size(vr8_3d,2), size(vr8_3d,3)]) @@ -620,8 +618,7 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) type(ArrayReference) :: ref if (present(arrdes)) then - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") + if (present(oClients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -671,8 +668,7 @@ subroutine MAPL_VarWriteNCpar_R8_4d(formatter, name, A, ARRDES, oClients, RC) integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") + if (present(oClients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -713,8 +709,7 @@ subroutine MAPL_VarWriteNCpar_R4_3d(formatter, name, A, ARRDES, oClients, RC) type(ArrayReference) :: ref if (present(arrdes)) then - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") + if (present(oclients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -781,8 +776,7 @@ subroutine MAPL_VarWriteNCpar_R8_3d(formatter, name, A, ARRDES, oClients, RC) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "outpur server is needed") + if (present(oclients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -841,7 +835,6 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC ! Local variables real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:) integer :: IM_WORLD - integer :: JM_WORLD integer :: status real(kind=ESMF_KIND_R4), allocatable :: recvbuf(:) @@ -854,8 +847,7 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC integer :: i1, j1, in, jn, global_dim(3) if (present(arrdes)) then - if(arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") + if(present(oClients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -876,7 +868,6 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC if (present(arrdes)) then IM_WORLD = arrdes%im_world - JM_WORLD = arrdes%jm_world ndes_x = size(arrdes%in) @@ -1019,17 +1010,6 @@ subroutine MAPL_VarReadNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, RC) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) - logical :: AM_READER - - AM_READER = .false. - if (present(arrdes)) then - if (arrdes%readers_comm/=MPI_COMM_NULL) then - AM_READER = .true. - end if - else - AM_READER = .true. - end if - if (present(arrdes) ) then IM_WORLD = arrdes%im_world @@ -1800,17 +1780,6 @@ subroutine MAPL_VarReadNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, off integer, allocatable :: activesendcounts(:) integer :: start(4), cnt(4) - logical :: AM_READER - - AM_READER = .false. - if (present(arrdes)) then - if (arrdes%readers_comm/=MPI_COMM_NULL) then - AM_READER = .true. - end if - else - AM_READER = .true. - end if - if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world @@ -2093,17 +2062,6 @@ subroutine MAPL_VarReadNCpar_R8_1d(formatter, name, A, layout, ARRDES, MASK, off integer, allocatable :: activesendcounts(:) integer :: start(4), cnt(4) - logical :: AM_READER - - AM_READER = .false. - if (present(arrdes)) then - if (arrdes%readers_comm/=MPI_COMM_NULL) then - AM_READER = .true. - end if - else - AM_READER = .true. - end if - if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world @@ -2378,8 +2336,7 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC integer :: i1, j1, in, jn, global_dim(3) if (present(arrdes)) then - if( arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") + if(present(oClients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) @@ -2540,17 +2497,6 @@ subroutine MAPL_VarReadNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, RC) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) - logical :: AM_READER - - AM_READER = .false. - if (present(arrdes)) then - if (arrdes%readers_comm/=MPI_COMM_NULL) then - AM_READER = .true. - end if - else - AM_READER = .true. - end if - if (present(arrdes)) then ndes_x = size(arrdes%in) @@ -3278,7 +3224,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) real(KIND=REAL64), allocatable :: lon(:), lat(:), lev(:), edges(:) integer, allocatable :: LOCATION(:), DIMS(:), UNGRID_DIMS(:,:) integer, allocatable :: UNIQUE_UNGRID_DIMS(:), ungriddim(:) - integer :: myungriddim1, myungriddim2 real(KIND=REAL64) :: x0,x1 integer :: arrayRank, KM_WORLD, DataType integer :: ungrid_dim_max_size, n_unique_ungrid_dims @@ -3322,8 +3267,9 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) character(len=ESMF_MAXSTR) :: positive type(StringVector) :: flip_vars type(ESMF_Field) :: lons_field, lats_field - logical :: isGridCapture + logical :: isGridCapture, have_oclients real(kind=ESMF_KIND_R8), pointer :: grid_lons(:,:), grid_lats(:,:), lons_field_ptr(:,:), lats_field_ptr(:,:) + have_oclients = present(oClients) call ESMF_FieldBundleGet(Bundle,FieldCount=nVars, name=BundleName, rc=STATUS) _VERIFY(STATUS) @@ -3519,7 +3465,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) ndims = ndims + 1 !WJ note: if arrdes%write_restart_by_oserver is true, all processors will participate - if (arrdes%writers_comm/=MPI_COMM_NULL .or. arrdes%write_restart_by_oserver) then + if (arrdes%writers_comm/=MPI_COMM_NULL .or. have_oclients ) then ! Create dimensions as needed if (Have_HorzVert .or. Have_HorzOnly) then @@ -3737,7 +3683,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) found = .false. do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) found = .true. exit @@ -3759,7 +3704,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) elseif(DIMS(1)==MAPL_DimsTileOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) exit end if @@ -3787,7 +3731,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) else if(DIMS(1)==MAPL_DimsHorzOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) exit end if @@ -3797,14 +3740,12 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) else if (DIMS(1)==MAPL_DimsTileOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) exit end if end do do j=1,n_unique_ungrid_dims if (ungrid_dims(i,2) == unique_ungrid_dims(j) ) then - myungriddim2 = j myUngridDimName2 = trim(unique_ungrid_dim_name(j)) exit end if @@ -3818,7 +3759,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) if (DIMS(1)==MAPL_DimsHorzVert) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) exit end if @@ -3835,14 +3775,12 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) else if(DIMS(1)==MAPL_DimsHorzOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then - myungriddim1 = j myUngridDimName1 = trim(unique_ungrid_dim_name(j)) exit end if end do do j=1,n_unique_ungrid_dims if (ungrid_dims(i,2) == unique_ungrid_dims(j) ) then - myungriddim2 = j myUngridDimName2 = trim(unique_ungrid_dim_name(j)) exit end if @@ -3888,8 +3826,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) _VERIFY(STATUS) - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), 'output server is needed') + if (have_oclients) then call oClients%set_optimal_server(1) iter = RstCollections%find(trim(BundleName)) if (iter == RstCollections%end()) then @@ -3991,7 +3928,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) call MAPL_FieldWriteNCPar(formatter, 'lats', lats_field, arrdes, HomePE=mask, oClients=oClients, rc=status) end if - if (arrdes%write_restart_by_oserver) then + if (have_oclients) then call oClients%done_collective_stage(_RC) call oClients%post_wait() call MPI_Info_free(info, status) diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index d72a5572d453..85ff1507b407 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -18,7 +18,7 @@ module Plain_netCDF_Time use MAPL_KeywordEnforcerMod use MAPL_ExceptionHandling use MAPL_ShmemMod - use mapl_ErrorHandlingMod + use MAPL_ErrorHandlingMod use MAPL_Constants use ESMF use pfio_NetCDF_Supplement @@ -55,8 +55,15 @@ module Plain_netCDF_Time interface bisect procedure :: bisect_find_LB_R8_I8 end interface bisect + contains + logical function is_success(c) + integer, intent(in) :: c + + is_success = (c == _SUCCESS) + + end function is_success subroutine get_ncfile_dimension(filename, nlon, nlat, tdim, key_lon, key_lat, key_time, rc) use netcdf @@ -70,62 +77,58 @@ subroutine get_ncfile_dimension(filename, nlon, nlat, tdim, key_lon, key_lat, ke character(len=ESMF_MAXSTR) :: lon_name, lat_name, time_name call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) - if (present(key_lon)) then + if(present(key_lon)) then lon_name=trim(key_lon) - ! call check_nc_status(nf90_inq_dimid(ncid, "lon", dimid), _RC) call check_nc_status(nf90_inq_dimid(ncid, trim(lon_name), dimid), _RC) call check_nc_status(nf90_inquire_dimension(ncid, dimid, len=nlon), _RC) endif - if (present(key_lat)) then + if(present(key_lat)) then lat_name=trim(key_lat) - ! call check_nc_status(nf90_inq_dimid(ncid, "lat", dimid), _RC) call check_nc_status(nf90_inq_dimid(ncid, trim(lat_name), dimid), _RC) call check_nc_status(nf90_inquire_dimension(ncid, dimid, len=nlat), _RC) call check_nc_status(nf90_close(ncid), _RC) endif - if (present(key_time)) then + if(present(key_time)) then time_name=trim(key_time) - ! call check_nc_status(nf90_inq_dimid(ncid, 'time', dimid), _RC) call check_nc_status(nf90_inq_dimid(ncid, trim(time_name), dimid), _RC) call check_nc_status(nf90_inquire_dimension(ncid, dimid, len=tdim), _RC) endif call check_nc_status(nf90_close(ncid), _RC) - ! debug summary - !write(6,*) "get_ncfile_dimension: nlat, nlon, tdim = ", nlat, nlon, tdim + _RETURN(_SUCCESS) + end subroutine get_ncfile_dimension - subroutine get_attribute_from_group(filename, group_name, var_name, attr_name, attr) + subroutine get_attribute_from_group(filename, group_name, var_name, attr_name, attr, rc) use netcdf use pfio_NetCDF_Supplement implicit none character(len=*), intent(in) :: filename, group_name, var_name, attr_name character(len=*), intent(INOUT) :: attr + integer, optional, intent(out) :: rc integer :: ncid, varid, ncid2 - integer :: rc, status, iret + integer :: status integer :: len, i, j, k integer :: xtype character(len=:), allocatable :: str integer(kind=C_INT) :: c_ncid, c_varid character(len=100) :: str2 - call check_nc_status ( nf90_open (fileName, NF90_NOWRITE, ncid2), rc ) - call check_nc_status ( nf90_inq_ncid (ncid2, group_name, ncid), rc ) - call check_nc_status ( nf90_inq_varid (ncid, var_name, varid), rc ) - call check_nc_status ( nf90_inquire_attribute(ncid, varid, attr_name, xtype, len=len), rc ) + call check_nc_status(nf90_open(fileName, NF90_NOWRITE, ncid2), _RC) + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + call check_nc_status(nf90_inq_varid(ncid, var_name, varid), _RC) + call check_nc_status(nf90_inquire_attribute(ncid, varid, attr_name, xtype, len=len), _RC) c_ncid= ncid c_varid= varid - !! print*, 'f: xtype, len=', xtype, len select case (xtype) case(NF90_STRING) - status = pfio_get_att_string(c_ncid, c_varid, attr_name, str) - _VERIFY(status) - case (NF90_CHAR) + _ASSERT(is_success(pfio_get_att_string(c_ncid, c_varid, attr_name, str)), 'Error return from pfio_get_att_string') + case(NF90_CHAR) allocate(character(len=len) :: str) - status = nf90_get_att(ncid, varid, trim(attr_name), str) + call check_nc_status(nf90_get_att(ncid, varid, trim(attr_name), str), _RC) case default _FAIL('code works only with string attribute') end select @@ -133,31 +136,34 @@ subroutine get_attribute_from_group(filename, group_name, var_name, attr_name, a ! get rid of T in 1970-01-01T00:00:0 str2=str(i+6:i+24) j=index(str2, 'T') - if (j>1) then + if(j>1) then k=len_trim(str2) str2=str2(1:j-1)//' '//str2(j+1:k) endif attr = str(1:i+5)//trim(str2) deallocate(str) - iret = nf90_close(ncid) + call check_nc_status(nf90_close(ncid), _RC) - end subroutine get_attribute_from_group + _RETURN(_SUCCESS) + end subroutine get_attribute_from_group - subroutine get_v2d_netcdf_R4(filename, name, array, Xdim, Ydim) + subroutine get_v2d_netcdf_R4(filename, name, array, Xdim, Ydim, rc) use netcdf implicit none character(len=*), intent(in) :: name, filename integer, intent(in) :: Xdim, Ydim real, dimension(Xdim,Ydim), intent(out) :: array + integer, optional, intent(out) :: rc + integer :: status integer :: ncid, varid real :: scale_factor, add_offset - integer :: rc, status, iret + integer :: iret - call check_nc_status ( nf90_open (trim(fileName), NF90_NOWRITE, ncid), _RC ) - call check_nc_status ( nf90_inq_varid (ncid, name, varid), _RC ) - call check_nc_status ( nf90_get_var (ncid, varid, array), _RC ) + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) + call check_nc_status(nf90_get_var(ncid, varid, array), _RC) iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) if(iret .eq. 0) array = array * scale_factor @@ -165,23 +171,28 @@ subroutine get_v2d_netcdf_R4(filename, name, array, Xdim, Ydim) iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) if(iret .eq. 0) array = array + add_offset ! - iret = nf90_close(ncid) + call check_nc_status(nf90_close(ncid), _RC) + + _RETURN(_SUCCESS) + end subroutine get_v2d_netcdf_R4 - subroutine get_v2d_netcdf_R8(filename, name, array, Xdim, Ydim) + subroutine get_v2d_netcdf_R8(filename, name, array, Xdim, Ydim, rc) use netcdf implicit none character(len=*), intent(in) :: name, filename integer, intent(in) :: Xdim, Ydim real(REAL64), dimension(Xdim,Ydim), intent(out) :: array + integer, optional, intent(out) :: rc + integer :: status integer :: ncid, varid real :: scale_factor, add_offset - integer :: rc, status, iret + integer :: iret - call check_nc_status ( nf90_open (trim(fileName), NF90_NOWRITE, ncid), _RC ) - call check_nc_status ( nf90_inq_varid (ncid, name, varid), _RC ) - call check_nc_status ( nf90_get_var (ncid, varid, array), _RC ) + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) + call check_nc_status(nf90_get_var(ncid, varid, array), _RC) iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) if(iret .eq. 0) array = array * scale_factor @@ -189,105 +200,114 @@ subroutine get_v2d_netcdf_R8(filename, name, array, Xdim, Ydim) iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) if(iret .eq. 0) array = array + add_offset ! - iret = nf90_close(ncid) + call check_nc_status(nf90_close(ncid), _RC) + + _RETURN(_SUCCESS) + end subroutine get_v2d_netcdf_R8 - subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name) + subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name, rc) use netcdf implicit none character(len=*), intent(in) :: name, filename character(len=*), optional, intent(in) :: group_name integer, intent(in) :: Xdim real(REAL64), dimension(Xdim), intent(out) :: array + integer, optional, intent(out) :: rc + integer :: status integer :: ncid, varid, ncid2 - integer :: rc, status, iret - call check_nc_status ( nf90_open (trim(fileName), NF90_NOWRITE, ncid), _RC ) - if (present(group_name)) then + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + if(present(group_name)) then ncid2= ncid - call check_nc_status ( nf90_inq_ncid ( ncid2, group_name, ncid), _RC ) + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) end if - call check_nc_status ( nf90_inq_varid (ncid, name, varid), _RC ) - call check_nc_status ( nf90_get_var (ncid, varid, array), _RC ) - iret = nf90_close(ncid) + call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) + call check_nc_status(nf90_get_var(ncid, varid, array), _RC) + call check_nc_status(nf90_close(ncid), _RC) + + _RETURN(_SUCCESS) + end subroutine get_v1d_netcdf_R8 subroutine check_nc_status(status, rc) use netcdf implicit none - integer, intent (in) :: status - integer, intent (out), optional :: rc - if(status /= nf90_noerr) then - print *, 'netCDF error: '//trim(nf90_strerror(status)) - endif - if(present(rc)) rc=status-nf90_noerr + integer, intent(in) :: status + integer, intent(out), optional :: rc + + _ASSERT(status == nf90_noerr, 'netCDF error: '//trim(nf90_strerror(status))) + + _RETURN(_SUCCESS) + end subroutine check_nc_status - subroutine time_nc_int_2_esmf (time, tunit, n, rc) + subroutine time_nc_int_2_esmf(time, tunit, n, rc) use ESMF implicit none - type (ESMF_TIME), intent(out) :: time + type(ESMF_TIME), intent(out) :: time integer, intent(in) :: n character(len=*), intent(in) :: tunit - integer, intent (out), optional :: rc + integer, intent(out), optional :: rc + integer :: status - type (ESMF_Time) :: time0 - type (ESMF_TimeInterval) :: dt + type(ESMF_Time) :: time0 + type(ESMF_TimeInterval) :: dt integer :: iyy,imm,idd,ih,im,is - call parse_timeunit (tunit, n, time0, dt, rc) + call parse_timeunit(tunit, n, time0, dt, _RC) time = time0 + dt ! check ! ----- - call ESMF_timeGet(time, yy=iyy, mm=imm, dd=idd, h=ih, m=im, s=is, rc=rc) + call ESMF_timeGet(time, yy=iyy, mm=imm, dd=idd, h=ih, m=im, s=is, _RC) write(6, *) 'obs_start: iyy,imm,idd,ih,im,is', iyy,imm,idd,ih,im,is - if(present(rc)) rc=0 + _RETURN(_SUCCESS) + end subroutine time_nc_int_2_esmf - subroutine time_esmf_2_nc_int (time, tunit, n, rc) + subroutine time_esmf_2_nc_int(time, tunit, n, rc) use ESMF implicit none - type (ESMF_TIME), intent(in) :: time - integer (ESMF_KIND_I8), intent(out) :: n + type(ESMF_TIME), intent(in) :: time + integer(ESMF_KIND_I8), intent(out) :: n character(len=*), intent(in) :: tunit - integer, intent (out), optional :: rc + integer, intent(out), optional :: rc + integer :: status - type (ESMF_Time) :: time0 - type (ESMF_TimeInterval) :: dt + type(ESMF_Time) :: time0 + type(ESMF_TimeInterval) :: dt n=0 - call parse_timeunit (tunit, n, time0, dt, rc) + call parse_timeunit(tunit, n, time0, dt, _RC) dt = time - time0 - ! -- To-be-deleted: this is a bug + ! assume unit is second ! - call ESMF_TimeIntervalGet(dt, s_i8=n) + call ESMF_TimeIntervalGet(dt, s_i8=n, _RC) - ! check - ! ----- - ! write(6, *) 'dt in unit second is', n + _RETURN(_SUCCESS) - if(present(rc)) rc=0 end subroutine time_esmf_2_nc_int - subroutine parse_timeunit_i4 (tunit, n, t0, dt, rc) + subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) use ESMF implicit none character(len=*), intent(in) :: tunit integer, intent(in) :: n - type (ESMF_Time), intent(out) :: t0 - type (ESMF_TimeInterval), intent(out) :: dt - integer, intent(out) :: rc + type(ESMF_Time), intent(out) :: t0 + type(ESMF_TimeInterval), intent(out) :: dt + integer, optional, intent(out) :: rc + integer :: status integer :: i character(len=ESMF_MAXSTR) :: s1, s2, s_time, s_unit @@ -303,38 +323,29 @@ subroutine parse_timeunit_i4 (tunit, n, t0, dt, rc) read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec -! write(6,*) 's_time, s_unit', trim(s_time), trim(s_unit) -! write(6,*) 's1, s2 ', trim(s1), trim(s2) -! write(6,*) 'y, m, d', y, m, d -! write(6,*) 'hour,min,sec', hour,min,sec + _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") + isec=n - if (trim(s_unit) == 'seconds') then - isec=n - else - stop "s_unit /= 'seconds' is not handled" - endif - - gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', rc=rc) + gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& - calendar=gregorianCalendar, rc=rc) - call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, rc=rc) + calendar=gregorianCalendar, _RC) + call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, _RC) - ! call ESMF_CalendarDestroy(gregorianCalendar, rc=rc) - ! if(present(rc)) rc=0 - rc=0 + _RETURN(_SUCCESS) end subroutine parse_timeunit_i4 - subroutine parse_timeunit_i8 (tunit, n, t0, dt, rc) + subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) use ESMF implicit none character(len=*), intent(in) :: tunit integer(ESMF_KIND_I8), intent(in) :: n - type (ESMF_Time), intent(out) :: t0 - type (ESMF_TimeInterval), intent(out) :: dt - integer, intent(out) :: rc + type(ESMF_Time), intent(out) :: t0 + type(ESMF_TimeInterval), intent(out) :: dt + integer, optional, intent(out) :: rc + integer :: status integer :: i character(len=ESMF_MAXSTR) :: s1, s2, s_time, s_unit @@ -350,51 +361,46 @@ subroutine parse_timeunit_i8 (tunit, n, t0, dt, rc) read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec -! write(6,*) 's_time, s_unit', trim(s_time), trim(s_unit) -! write(6,*) 's1, s2 ', trim(s1), trim(s2) -! write(6,*) 'y, m, d', y, m, d -! write(6,*) 'hour,min,sec', hour,min,sec - - if (trim(s_unit) == 'seconds') then - isec=n - else - stop "s_unit /= 'seconds' is not handled" - endif + _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") + isec=n - gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', rc=rc) + gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& - calendar=gregorianCalendar, rc=rc) - call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, rc=rc) + calendar=gregorianCalendar, _RC) + call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, _RC) - ! call ESMF_CalendarDestroy(gregorianCalendar, rc=rc) - ! if(present(rc)) rc=0 - rc=0 + _RETURN(_SUCCESS) end subroutine parse_timeunit_i8 - subroutine ESMF_time_to_two_integer (time, itime, rc) - type (ESMF_Time), intent(in) :: time + + subroutine ESMF_time_to_two_integer(time, itime, rc) + type(ESMF_Time), intent(in) :: time integer, intent(out) :: itime(2) integer, intent(out), optional :: rc integer :: i1, i2 integer :: yy, mm, dd, h, m, s + integer :: status - call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, rc=rc) + call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) i2=h*10000 + m*100 + s i1=yy*10000 + mm*100 + dd - ! itime= i1*10**6 + i2 itime(1)=i1 itime(2)=i2 + + _RETURN(_SUCCESS) + end subroutine ESMF_time_to_two_integer - subroutine two_integer_to_ESMF_time (time, itime, rc) - type (ESMF_Time), intent(out) :: time + subroutine two_integer_to_ESMF_time(time, itime, rc) + type(ESMF_Time), intent(out) :: time integer, intent(in) :: itime(2) integer, intent(out), optional :: rc integer :: i1, i2 integer :: yy, mm, dd, h, m, s + integer :: status i1= itime(1) yy= i1/10000 @@ -406,30 +412,27 @@ subroutine two_integer_to_ESMF_time (time, itime, rc) m= mod(i2, 10000)/100 s= mod(i2, 100) - ! write(6,*) 'yy, mm, dd, h, m, s', yy, mm, dd, h, m, s - call ESMF_TimeSet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, rc=rc) + call ESMF_TimeSet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) + + _RETURN(_SUCCESS) end subroutine two_integer_to_ESMF_time - subroutine hms_2_s (hms, sec, rc) + integer function hms_2_s(hms) integer, intent(in) :: hms - integer, intent(out):: sec - integer, intent(out), optional :: rc integer :: h, m, s h = hms/10000 m = mod(hms, 10000)/100 s = mod(hms, 100) - sec= h*3600 + m*60 + s - if (present(rc)) rc=0 + hms_2_s = h*3600 + m*60 + s - end subroutine hms_2_s + end function hms_2_s - - subroutine bisect_find_LB_R8_I8 (xa, x, n, n_LB, n_UB, rc) + subroutine bisect_find_LB_R8_I8(xa, x, n, n_LB, n_UB, rc) implicit none real(ESMF_KIND_R8), intent(in) :: xa(:) ! 1D array real(ESMF_KIND_R8), intent(in) :: x ! pt @@ -437,6 +440,7 @@ subroutine bisect_find_LB_R8_I8 (xa, x, n, n_LB, n_UB, rc) integer(ESMF_KIND_I8), intent(in), optional :: n_LB ! opt in : LB integer(ESMF_KIND_I8), intent(in), optional :: n_UB ! opt in : UB integer, intent(out), optional :: rc + integer :: status integer(ESMF_KIND_I8) :: k, klo, khi, dk, LB, UB integer :: i, nmax @@ -446,7 +450,6 @@ subroutine bisect_find_LB_R8_I8 (xa, x, n, n_LB, n_UB, rc) if(present(n_UB)) UB=n_UB klo=LB; khi=UB; dk=1 - ! write(6,*) 'init klo, khi', klo, khi if ( xa(LB ) > xa(UB) ) then klo= UB khi= LB @@ -459,15 +462,12 @@ subroutine bisect_find_LB_R8_I8 (xa, x, n, n_LB, n_UB, rc) ! ! Y(n) < x <= Y(n+1) - rc=-1 + status=-1 if ( x <= xa(klo) ) then - !write(6,*) 'xa(klo), xa(khi), x', xa(klo), xa(khi), x n=klo-1 - !write(6,*) 'warning in bisect_find_LB_R8_I8: x < array:LB' return elseif ( x > xa(khi) ) then n=khi - !write(6,*) 'warning in bisect_find_LB_R8_I8: x > array:UB' return endif @@ -481,35 +481,34 @@ subroutine bisect_find_LB_R8_I8 (xa, x, n, n_LB, n_UB, rc) endif if( abs(klo-khi) <= 1 ) then n=klo - rc=0 - return + status=0 + exit endif enddo + _RETURN(_SUCCESS) + end subroutine bisect_find_LB_R8_I8 - subroutine convert_twostring_2_esmfinterval (symd, shms, interval, rc) + subroutine convert_twostring_2_esmfinterval(symd, shms, interval, rc) character(len=*) :: symd character(len=*) :: shms - type (ESMF_TimeInterval), intent(out) :: interval + type(ESMF_TimeInterval), intent(out) :: interval integer, optional, intent(out) :: rc character(len=20) :: s1, s2 integer :: y, m, d, hh, mm, ss - + integer :: status s1=trim(symd) read(s1, '(3i2)') y, m, d s2=trim(shms) read(s2, '(3i2)') hh, mm, ss - ! debug - !write(6,'(3a10)') 's1, s2', s1, s2 - !write(6,*) 'int y,m,d,hh,mm,ss', y,m,d,hh,mm,ss + call ESMF_TimeIntervalSet(interval, yy=y, mm=m, d=d, h=hh, m=mm, s=ss, _RC) - call ESMF_TimeIntervalSet(interval, yy=y, mm=m, d=d, h=hh, m=mm, s=ss, rc=rc) + _RETURN(_SUCCESS) - if (present(rc)) rc=0 end subroutine convert_twostring_2_esmfinterval end module Plain_NetCDF_Time diff --git a/base/Regrid_Functions_Mod.F90 b/base/Regrid_Functions_Mod.F90 index a1f78075b3ca..8813a8bed555 100644 --- a/base/Regrid_Functions_Mod.F90 +++ b/base/Regrid_Functions_Mod.F90 @@ -594,7 +594,6 @@ Subroutine swapCS(II,JJ,nX,nY,nVal) Integer :: iFace Integer :: xFace Integer :: minJJ, maxJJ, minJJOut - Integer :: II0(nVal) Integer :: JJ0(nVal) Integer :: I Integer, Parameter :: faceMap(6) = (/4,5,1,2,6,3/) @@ -602,7 +601,6 @@ Subroutine swapCS(II,JJ,nX,nY,nVal) _UNUSED_DUMMY(nY) ! Copy input - II0 = II JJ0 = JJ Do iFace = 1,6 diff --git a/base/tests/CMakeLists.txt b/base/tests/CMakeLists.txt index e1d34f91927b..46577909e502 100644 --- a/base/tests/CMakeLists.txt +++ b/base/tests/CMakeLists.txt @@ -17,6 +17,7 @@ set (TEST_SRCS test_MAPL_NetCDF.pf Test_MAPL_Resource.pf # test_MAPL_ISO8601_DateTime_ESMF.pf +# test_MAPL_DateTime_Parsing_ESMF.pf ) # SRCS are mostly mocks to facilitate tests diff --git a/base/tests/test_MAPL_DateTime_Parsing_ESMF.pf b/base/tests/test_MAPL_DateTime_Parsing_ESMF.pf new file mode 100644 index 000000000000..84032689f55e --- /dev/null +++ b/base/tests/test_MAPL_DateTime_Parsing_ESMF.pf @@ -0,0 +1,59 @@ +#include "MAPL_Exceptions.h" +!=============================================================================== +! TEST_MAPL_DATETIMEPARSING_ESMF +!=============================================================================== +module test_MAPL_DateTime_Parsing_ESMF + use MAPL_DateTime_Parsing + use MAPL_DateTime_Parsing_ESMF + use MAPL_CF_Time + use ESMF + use, intrinsic :: iso_fortran_env, only: R64 => real64, R32 => real32 + + implicit none + + integer, parameter :: SUCCESS = _SUCCESS !wdb deleteme + +contains + + @test + subroutine test_set_ESMF_TimeInterval_integer() + integer :: duration = 1800, actual + type(datetime_duration) :: dt_dur + character(len=*), parameter :: units = 'seconds since 1999-12-31 23:29:59' + type(ESMF_TimeInterval) :: interval + integer :: status + + call convert_CF_Time_to_datetime_duration(duration, units, dt_dur, rc = status) + @assertEqual(_SUCCESS, status, 'Conversion unsuccessful') + + end subroutine test_set_ESMF_TimeInterval_integer + + @test + subroutine test_set_ESMF_TimeInterval_real() + real(R64) :: duration = 1800.0, actual + type(datetime_duration) :: dt_dur + character(len=*), parameter :: units = 'seconds since 1999-12-31 23:29:59' + type(ESMF_TimeInterval) :: interval + integer :: status + + call convert_CF_Time_to_datetime_duration(duration, units, dt_dur, rc = status) + @assertEqual(_SUCCESS, status, 'Conversion unsuccessful') + + end subroutine test_set_ESMF_TimeInterval_real + + @test + subroutine test_ESMF_Time_from_ISO8601() + character(len=*), parameter :: isostring = '1999-12-31T23:29:59' + character(len=len(isostring)) :: actual + type(ESMF_Time) :: time + integer :: status + + call set_ESMF_Time_from_ISO8601(time, isostring, rc = status) + @assertTrue(status == _SUCCESS, 'Failed to set ESMF_Time') + call ESMF_TimeGet(time, timeStringISOFrac = actual, rc = status) + @assertTrue(status == _SUCCESS, 'Failed to get isostring') + @assertEqual(isostring, actual, 'ISO8601 strings do not match.') + + end subroutine test_ESMF_Time_from_ISO8601 + +end module test_MAPL_DateTime_Parsing_ESMF diff --git a/base/tests/test_MAPL_NetCDF.pf b/base/tests/test_MAPL_NetCDF.pf index db929d3348cc..82b85029c50c 100644 --- a/base/tests/test_MAPL_NetCDF.pf +++ b/base/tests/test_MAPL_NetCDF.pf @@ -1,6 +1,10 @@ #include "MAPL_Exceptions.h" #include "MAPL_ErrLog.h" +!=============================================================================== +! TEST_MAPL_NETCDF +!=============================================================================== module test_MAPL_NetCDF + use MAPL_ExceptionHandling use MAPL_NetCDF use ESMF @@ -9,6 +13,7 @@ module test_MAPL_NetCDF implicit none type(ESMF_CalKind_Flag), parameter :: CALKIND_FLAG_DEF = ESMF_CALKIND_GREGORIAN + integer, parameter :: SECONDS_PER_MINUTE = 60 contains @@ -17,260 +22,133 @@ contains integer :: status call ESMF_CalendarSetDefault(CALKIND_FLAG_DEF, rc=status) - if(status /= 0) write(*, *) 'Failed to set ESMF_Calendar' + if(status /= _SUCCESS) write(*, *) 'Failed to set ESMF_Calendar' end subroutine set_up - @Test - subroutine test_convert_NetCDF_DateTime_to_ESMF() - character(len=*), parameter :: expected_tunit = 'seconds' - integer, parameter :: int_time = 1800 - character(len=*), parameter :: units_string = expected_tunit // ' since 2012-08-26 12:36:37' - character(len=*), parameter :: t0_iso_string = '2012-08-26T12:36:37' - character(len=*), parameter :: t1_iso_string = '2012-08-26T13:06:37' - type(ESMF_TimeInterval) :: expected_interval - type(ESMF_Time) :: expected_time0 - type(ESMF_Time) :: expected_time1 - - type(ESMF_TimeInterval) :: interval - type(ESMF_Time) :: time0 - type(ESMF_Time) :: time1 - character(len=:), allocatable :: tunit - integer :: rc, status - - call ESMF_TimeSet(expected_time0, timeString=t0_iso_string, _RC) - call ESMF_TimeSet(expected_time1, timeString=t1_iso_string, _RC) - call ESMF_TimeIntervalSet(expected_interval, startTime=expected_time0, s=int_time, _RC) - - call convert_NetCDF_DateTime_to_ESMF(int_time, units_string, interval, time0, time1=time1, tunit=tunit, _RC) - @assertTrue(expected_time0 == time0, 'Mismatch for time0') - @assertTrue(expected_time1 == time1, 'Mismatch for time1') - @assertTrue(expected_interval == interval, 'Mismatch for interval') - - end subroutine test_convert_NetCDF_DateTime_to_ESMF - - @Test - subroutine test_convert_ESMF_to_NetCDF_DateTime() - character(len=*), parameter :: tunit = 'seconds' - character(len=*), parameter :: t0_iso_string = '2013-08-26T12:34:56' - type(ESMF_Time) :: t0 - character(len=*), parameter :: t1_iso_string = '2013-08-26T13:04:56' - type(ESMF_Time) :: t1 - type(ESMF_TimeInterval) :: interval - integer, parameter :: span = 1800 - character(len=*), parameter :: expected_units_string = tunit // ' since 2013-08-26 12:34:56' - integer, parameter :: expected_int_time = span - integer :: int_time - character(len=:), allocatable :: units_string - integer :: rc, status - - call ESMF_TimeSet(t0, t0_iso_string, _RC) - call ESMF_TimeSet(t1, t1_iso_string, _RC) - call ESMF_TimeIntervalSet(interval, startTime=t0, s=span, _RC) - - call convert_ESMF_to_NetCDF_DateTime(tunit, t0, int_time, units_string, t1=t1, _RC) - @assertEqual(expected_int_time, int_time, 'Using t1, expected_int_time /= int_time') - @assertEqual(expected_units_string, units_string, 'Using t1, expected_units_strin g/= units_string') + logical function rational_equals(na, nb) + integer, intent(in) :: na(2) + integer, intent(in) :: nb(2) - call convert_ESMF_to_NetCDF_DateTime(tunit, t0, int_time, units_string, interval=interval, _RC) - @assertEqual(expected_int_time, int_time, 'Using interval, expected_int_time /= int_time') - @assertEqual(expected_units_string, units_string, 'Using interval, expected_units_strin g/= units_string') - - end subroutine test_convert_ESMF_to_NetCDF_DateTime - - @Test - subroutine test_make_ESMF_TimeInterval() - character(len=*), parameter :: tunit = 'seconds' - character(len=*), parameter :: iso_string = '2013-08-26T12:34:56' - integer, parameter :: span = 1800 - type(ESMF_TimeInterval) :: expected_interval - type(ESMF_Time) :: t0 - type(ESMF_TimeInterval) :: interval - integer :: rc, status + rational_equals = ( na(1) * nb(2) == na(2) * nb(1) ) - call ESMF_TimeSet(t0, iso_string, _RC) - call ESMF_TimeIntervalSet(expected_interval, startTime=t0, s=span, _RC) - call make_ESMF_TimeInterval(span, tunit, t0, interval, _RC) - @assertTrue(expected_interval == interval, 'ESMF_TimeInterval variables do not match.') + end function rational_equals - end subroutine test_make_ESMF_TimeInterval - - @Test - subroutine test_make_NetCDF_DateTime_int_time() - character(len=*), parameter :: tunit = 'seconds' - character(len=*), parameter :: iso_string = '2013-08-26T12:34:56' - type(ESMF_TimeInterval) :: interval - type(ESMF_Time) :: t0 - integer, parameter :: expected_int_time = 1800 - integer :: int_time - integer :: status, rc - - call ESMF_TimeSet(t0, iso_string, _RC) - call ESMF_TimeIntervalSet(interval, startTime=t0, s=expected_int_time, _RC) - - call make_NetCDF_DateTime_int_time(interval, t0, tunit, int_time, _RC) - @assertEqual(expected_int_time, int_time, 'int_time does not match.') + function ESMF_Times_Equal(timeu, timev) result(tval) + type(ESMF_Time), intent(in) :: timeu, timev + logical :: tval + integer :: uyy, umm, udd, uh, um, us, usN, usD + integer :: vyy, vmm, vdd, vh, vm, vs, vsN, vsD + integer :: status - end subroutine test_make_NetCDF_DateTime_int_time + tval = .FALSE. + call ESMF_TimeGet(timeu, yy=uyy, mm=umm, dd=udd, h=uh, m=um, d=us, sN=usN, sD=usD, rc = status) + if(status /= _SUCCESS) return + call ESMF_TimeGet(timev, yy=vyy, mm=vmm, dd=vdd, h=vh, m=vm, d=vs, sN=vsN, sD=vsD, rc = status) + if(status /= _SUCCESS) return - @Test - subroutine test_make_NetCDF_DateTime_units_string() - type(ESMF_Time) :: t0 - character(len=*), parameter :: tunit = 'seconds' - character(len=*), parameter :: expected = tunit // ' since 2012-08-26 08:36:37' - character(len=:), allocatable :: actual - integer :: status, rc + tval = ( (uyy == vyy) .and. (umm == vmm) .and. (udd == vdd) & + .and. (uh == vh) .and. (um == vm) .and. (us == vs) & + .and. rational_equals([usN, usD], [vsN, vsD]) ) - call ESMF_TimeSet(t0, yy=2012, mm=08, dd=26, h=08, m=36, s=37, _RC) - call make_NetCDF_DateTime_units_string(t0, tunit, actual, _RC) - @assertEqual(expected, actual, 'Strings don''t match: ' // expected // '/=' // actual) - end subroutine test_make_NetCDF_DateTime_units_string + end function ESMF_Times_Equal @Test - subroutine test_convert_ESMF_Time_to_NetCDF_DateTimeString() - type(ESMF_Time) :: esmf_datetime - character(len=*), parameter :: expected = '2022-08-26 07:30:37' - integer, parameter :: yy = 2022 - integer, parameter :: mm = 08 - integer, parameter :: dd = 26 - integer, parameter :: h = 07 - integer, parameter :: m = 30 - integer, parameter :: s = 37 - character(len=:), allocatable :: actual - integer :: status, rc + subroutine test_convert_NetCDF_DateTime_to_ESMF_integer() + integer :: duration + integer :: yy, mm, dd, h, m, s, m_time + character(len=*), parameter :: UNITS = 'seconds' + character(len=*), parameter :: NOT_EQUAL = ' /= ' + character(len=:), allocatable :: tunit, units_string + type(ESMF_Time) :: time, etime, btime, ebtime + type(ESMF_TimeInterval) :: time_interval + character(len=ESMF_MAXSTR) :: expected_base_datetime_string + character(len=ESMF_MAXSTR) :: expected_datetime_string + character(len=ESMF_MAXSTR) :: actual_base_datetime_string + character(len=ESMF_MAXSTR) :: actual_datetime_string + character(len=:), allocatable :: msg_time, msg_base_time, msg_tunit + integer :: status - call ESMF_TimeSet(esmf_datetime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) - call convert_ESMF_Time_to_NetCDF_DateTimeString(esmf_datetime, actual, _RC) - @assertEqual(expected, actual, 'Strings don''t match: ' // expected // '/=' // actual) - end subroutine test_convert_ESMF_Time_to_NetCDF_DateTimeString + yy = 1999 + mm = 12 + dd = 31 + h = 23 + m = 29 + m_time = 59 + s = 59 + duration = ( m_time - m ) * SECONDS_PER_MINUTE + units_string = UNITS // ' since 1999-12-31 23:29:59' + + call ESMF_TimeSet(etime, yy=yy, mm=mm, dd=dd, h=h, m=m_time, s=s, rc=status) + @assertTrue(status == _SUCCESS, 'Unable to create expected ESMF_Time') + call ESMF_TimeGet(etime, timeString = expected_datetime_string, rc=status) + + call ESMF_TimeSet(ebtime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, rc=status) + @assertTrue(status == _SUCCESS, 'Unable to create expected base ESMF_Time') + call ESMF_TimeGet(ebtime, timeString = expected_base_datetime_string, rc=status) + + call get_ESMF_Time_from_NetCDF_DateTime(duration, units_string, time_interval, btime, & + time = time, time_unit = tunit, rc = status) + @assertTrue(status == _SUCCESS, 'Conversion failed') + call ESMF_TimeGet(btime, timeString = actual_base_datetime_string, rc=status) + call ESMF_TimeGet(time, timeString = actual_datetime_string, rc=status) + msg_time = trim(actual_datetime_string) // NOT_EQUAL // trim(expected_datetime_string) + msg_base_time = trim(actual_base_datetime_string) // NOT_EQUAL // trim(expected_base_datetime_string) + msg_tunit = trim(tunit) // NOT_EQUAL // trim(UNITS) + + @assertTrue(ESMF_Times_Equal(ebtime, btime), 'base ESMF_Time values do not match: ' // msg_base_time) + @assertTrue(trim(tunit) == trim(UNITS), "Time units don't match: " // msg_tunit) + @assertTrue(ESMF_Times_Equal(etime, time), 'ESMF_Time values do not match: ' // msg_time) + + end subroutine test_convert_NetCDF_DateTime_to_ESMF_integer @Test - subroutine test_convert_NetCDF_DateTimeString_to_ESMF_Time() - character(len=19), parameter:: netcdf_string='2023-01-31 14:04:37' - type(ESMF_Time) :: etime - integer :: yy, mm, dd, h, m, s - integer :: status, rc - - call convert_NetCDF_DateTimeString_to_ESMF_Time(netcdf_string, etime, _RC) - call ESMF_TimeGet(etime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) - @assertEqual(2023, yy, 'Incorrect year') - @assertEqual(01, mm, 'Incorrect month') - @assertEqual(31, dd, 'Incorrect day') - @assertEqual(14, h, 'Incorrect hour') - @assertEqual(04, m, 'Incorrect minute') - @assertEqual(37, s, 'Incorrect second') - - end subroutine test_convert_NetCDF_DateTimeString_to_ESMF_Time - -! @Test - subroutine test_is_time_unit() - - @assertTrue(is_time_unit('years')) - @assertTrue(is_time_unit('months')) - @assertTrue(is_time_unit('days')) - @assertTrue(is_time_unit('hours')) - @assertTrue(is_time_unit('minutes')) - @assertTrue(is_time_unit('seconds')) - @assertTrue(is_time_unit('milliseconds')) - @assertTrue(is_time_unit(' milliseconds ')) - - @assertFalse(is_time_unit('nanoseconds')) - @assertFalse(is_time_unit('year')) - - end subroutine test_is_time_unit - -! @Test - subroutine test_lr_trim() - @assertEqual('word', lr_trim(' word')) - @assertEqual('word', lr_trim('word ')) - @assertEqual('word', lr_trim(' word ')) - end subroutine test_lr_trim - -! @test - subroutine test_get_shift_sign() - character(len=:), allocatable :: preposition - integer, parameter :: expected = 1 - - preposition = 'since' - @assertEqual(expected, get_shift_sign(preposition)) - preposition = 'before' - @assertFalse(get_shift_sign(preposition) == expected) - preposition = '' - @assertFalse(get_shift_sign(preposition) == expected) - end subroutine test_get_shift_sign - -! @test - subroutine test_split() - character(len=*), parameter :: head = 'head' - character(len=*), parameter :: tail = 'tail' - character(len=*), parameter :: delim = '::' - character(len=*), parameter :: test_string = head // delim // tail - character(len=:), allocatable :: parts(:) - - parts = split_all(test_string, delim) - @assertEqual(2, size(parts)) - @assertEqual(head, parts(1)) - @assertEqual(tail, parts(2)) - - end subroutine test_split - -! @test - subroutine test_split_all() - character(len=4), parameter :: chunk(6) = ['mice', 'dogs', 'rats', 'fish', 'deer', 'pigs'] - character(len=*), parameter :: dlm = '::' - character(len=:), allocatable :: test_string - character(len=:), allocatable :: parts(:) - integer :: i - - test_string = chunk(1) - do i = 2, size(chunk) - test_string = test_string // dlm // chunk(i) - end do - - parts = split_all(test_string, dlm) - @assertEqual(size(parts), size(chunk)) - do i = 1, size(chunk) - @assertEqual(chunk(i), parts(i)) - end do - - end subroutine test_split_all - -! @test - subroutine test_is_valid_netcdf_datetime_string() - character(len=:), allocatable :: string - -! string = '' -! @assertTrue(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - string = '1970-01-01 23:59:59' - @assertTrue(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - string = '1970-01-01 23:59:59' - @assertFalse(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - string = '1970:01-01 23:59:59' - @assertFalse(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - string = '1970-01-01 23-59:59' - @assertFalse(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - string = '1970-01-01T23:59:59' - @assertFalse(is_valid_netcdf_datetime_string(string), string // ' is not a valid NetCDF datetime string.') - - end subroutine test_is_valid_netcdf_datetime_string - -! @test - subroutine test_convert_to_integer() - character(len=:), allocatable :: str - integer :: expected, actual, status - integer, parameter :: SUCCESSFUL = 0 - - expected = 2023 - str = '2023' - call convert_to_integer(str, actual, rc = status) - @assertEqual(SUCCESSFUL, status, 'Unsuccessful conversion: ' // str) - @assertEqual(expected, actual, 'Incorrect conversion: ' // str) + subroutine test_convert_NetCDF_DateTime_to_ESMF_real() + real(kind=ESMF_KIND_R8) :: duration + integer :: yy, mm, dd, h, m, s, m_time + character(len=*), parameter :: UNITS = 'seconds' + character(len=*), parameter :: NOT_EQUAL = ' /= ' + character(len=:), allocatable :: tunit, units_string + type(ESMF_Time) :: time, etime, btime, ebtime + type(ESMF_TimeInterval) :: time_interval + character(len=ESMF_MAXSTR) :: expected_base_datetime_string + character(len=ESMF_MAXSTR) :: expected_datetime_string + character(len=ESMF_MAXSTR) :: actual_base_datetime_string + character(len=ESMF_MAXSTR) :: actual_datetime_string + character(len=:), allocatable :: msg_time, msg_base_time, msg_tunit + integer :: status - end subroutine test_convert_to_integer + yy = 1999 + mm = 12 + dd = 31 + h = 23 + m = 29 + m_time = 59 + s = 59 + duration = ( m_time - m ) * SECONDS_PER_MINUTE + units_string = UNITS // ' since 1999-12-31 23:29:59' + + call ESMF_TimeSet(etime, yy=yy, mm=mm, dd=dd, h=h, m=m_time, s=s, rc=status) + @assertTrue(status == _SUCCESS, 'Unable to create expected ESMF_Time') + call ESMF_TimeGet(etime, timeString = expected_datetime_string, rc=status) + + call ESMF_TimeSet(ebtime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, rc=status) + @assertTrue(status == _SUCCESS, 'Unable to create expected base ESMF_Time') + call ESMF_TimeGet(ebtime, timeString = expected_base_datetime_string, rc=status) + + call get_ESMF_Time_from_NetCDF_DateTime(duration, units_string, time_interval, btime, & + time = time, time_unit = tunit, rc = status) + @assertTrue(status == _SUCCESS, 'Conversion failed') + call ESMF_TimeGet(btime, timeString = actual_base_datetime_string, rc=status) + call ESMF_TimeGet(time, timeString = actual_datetime_string, rc=status) + msg_time = trim(actual_datetime_string) // NOT_EQUAL // trim(expected_datetime_string) + msg_base_time = trim(actual_base_datetime_string) // NOT_EQUAL // trim(expected_base_datetime_string) + msg_tunit = trim(tunit) // NOT_EQUAL // trim(UNITS) + + @assertTrue(ESMF_Times_Equal(ebtime, btime), 'base ESMF_Time values do not match: ' // msg_base_time) + @assertTrue(trim(tunit) == trim(UNITS), "Time units don't match: " // msg_tunit) + @assertTrue(ESMF_Times_Equal(etime, time), 'ESMF_Time values do not match: ' // msg_time) + + end subroutine test_convert_NetCDF_DateTime_to_ESMF_real end module test_MAPL_NetCDF diff --git a/benchmarks/io/CMakeLists.txt b/benchmarks/io/CMakeLists.txt index 59937eb70bdf..d82b493693a3 100644 --- a/benchmarks/io/CMakeLists.txt +++ b/benchmarks/io/CMakeLists.txt @@ -1,3 +1,4 @@ add_subdirectory(raw_bw) add_subdirectory(gatherv) add_subdirectory(combo) +add_subdirectory(checkpoint_simulator) diff --git a/benchmarks/io/checkpoint_simulator/CMakeLists.txt b/benchmarks/io/checkpoint_simulator/CMakeLists.txt new file mode 100644 index 000000000000..718d3b706d4e --- /dev/null +++ b/benchmarks/io/checkpoint_simulator/CMakeLists.txt @@ -0,0 +1,14 @@ +set(exe checkpoint_simulator.x) + +ecbuild_add_executable ( + TARGET ${exe} + SOURCES checkpoint_simulator.F90 + DEFINITIONS USE_MPI) + +target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse esmf ) +target_include_directories (${exe} PUBLIC $) + +# CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 +if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_link_libraries(${exe} PRIVATE OpenMP::OpenMP_Fortran) +endif () diff --git a/benchmarks/io/checkpoint_simulator/README.md b/benchmarks/io/checkpoint_simulator/README.md new file mode 100644 index 000000000000..d2cba319adc8 --- /dev/null +++ b/benchmarks/io/checkpoint_simulator/README.md @@ -0,0 +1,19 @@ +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 + +- "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 +- "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) +- "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 + +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 diff --git a/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 new file mode 100644 index 000000000000..c82f395c3c11 --- /dev/null +++ b/benchmarks/io/checkpoint_simulator/checkpoint_simulator.F90 @@ -0,0 +1,747 @@ +#include "MAPL_ErrLog.h" +module mapl_checkpoint_support_mod + + use ESMF + use MPI + use NetCDF + use MAPL_ErrorHandlingMod + use, intrinsic :: iso_fortran_env, only: INT64, REAL64, REAL32 + implicit none + + real(kind=REAL64), parameter :: byte_to_mega = (1.0d0/1024.0d0)*(1.0d0/1024.0d0) + type array_wrapper + character(len=:), allocatable :: field_name + real, allocatable :: field(:,:,:) + end type + + type test_support + integer :: nx,ny,im_world,lm,num_arrays,num_writers + integer :: gather_comm + integer :: writers_comm + integer :: xcomm + integer :: ycomm + integer :: ncid + integer, allocatable :: i1(:),in(:),j1(:),jn(:) + type(array_wrapper), allocatable :: bundle(:) + integer :: face_index + integer(kind=INT64) :: write_counter + logical :: do_chunking + logical :: gather_3D + logical :: split_file + logical :: extra_info + logical :: write_barrier + logical :: do_writes + real(kind=REAL64) :: data_volume + real(kind=REAL64) :: time_writing + real(kind=REAL64) :: time_mpi + logical :: netcdf_writes + integer :: n_trials + logical :: random + + integer(kind=INT64) :: mpi_time + integer(kind=INT64) :: write_3d_time + integer(kind=INT64) :: write_2d_time + integer(kind=INT64) :: create_file_time + integer(kind=INT64) :: close_file_time + contains + procedure :: set_parameters + procedure :: compute_decomposition + procedure :: allocate_n_arrays + procedure :: create_arrays + procedure :: create_communicators + procedure :: create_file + procedure :: close_file + procedure :: write_file + procedure :: write_level + procedure :: write_variable + procedure :: reset + end type + +contains + + subroutine set_parameters(this,config_file) + class(test_support), intent(inout) :: this + character(len=*), intent(in) :: config_file + type(ESMF_Config) :: config + + logical :: is_present + integer :: comm_size, status,error_code + + config = ESMF_ConfigCreate() + this%extra_info = .false. + this%write_barrier = .false. + this%do_writes = .true. + call ESMF_ConfigLoadFile(config,config_file) + call ESMF_ConfigGetAttribute(config,this%nx,label="NX:") + call ESMF_ConfigGetAttribute(config,this%ny,label="NY:") + call ESMF_ConfigGetAttribute(config,this%im_world,label="IM_WORLD:") + call ESMF_ConfigGetAttribute(config,this%lm,label="LM:") + call ESMF_ConfigGetAttribute(config,this%num_writers,label="NUM_WRITERS:") + call ESMF_ConfigGetAttribute(config,this%num_arrays,label="NUM_ARRAYS:") + this%do_chunking = get_logical_key(config,"CHUNK:",.true.) + this%gather_3d = get_logical_key(config,"GATHER_3D:",.false.) + this%split_file = get_logical_key(config,"SPLIT_FILE:",.false.) + this%extra_info = get_logical_key(config,"EXTRA_INFO:",.false.) + 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%random = get_logical_key(config,"RANDOM_DATA:",.true.) + + 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) + if (comm_size /= (this%nx*this%ny*6)) call MPI_Abort(mpi_comm_world,error_code,status) + + contains + + function get_logical_key(config,label,default_val) result(val) + logical :: val + type(ESMF_Config), intent(Inout) :: config + character(len=*), intent(in) :: label + logical, intent(in) :: default_val + + logical :: is_present + call ESMF_ConfigFindlabel(config,label,isPresent=is_present) + if (is_present) then + call ESMF_ConfigGetAttribute(config,val,label=label) + else + val = default_val + end if + end function + + function get_integer_key(config,label,default_val) result(val) + integer :: val + type(ESMF_Config), intent(Inout) :: config + character(len=*), intent(in) :: label + integer, intent(in) :: default_val + + logical :: is_present + call ESMF_ConfigFindlabel(config,label,isPresent=is_present) + if (is_present) then + call ESMF_ConfigGetAttribute(config,val,label=label) + else + val = default_val + end if + end function + + end subroutine + + subroutine reset(this) + class(test_support), intent(inout) :: this + 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 + end subroutine + + function compute_decomposition(this,axis) result(decomp) + integer, allocatable :: decomp(:) + class(test_support), intent(inout) :: this + integer, intent(in) :: axis + + integer :: n_loc, rm, im, n + integer :: seed_size + + if (axis == 1) then + n_loc = this%nx + else if (axis ==2) then + n_loc = this%ny + end if + allocate(decomp(n_loc)) + im = this%im_world/n_loc + rm = this%im_world-n_loc*im + do n = 1,n_loc + decomp(n) = im + if (n.le.rm) decomp(n) = im+1 + enddo + + end function + + subroutine allocate_n_arrays(this,im,jm) + class(test_support), intent(inout) :: this + integer, intent(in) :: im + integer, intent(in) :: jm + + integer :: n,rank,status + character(len=3) :: formatted_int + integer :: seed_size + integer, allocatable :: seeds(:) + + call MPI_COMM_RANK(MPI_COMM_WORLD,rank,status) + call random_seed(size=seed_size) + allocate(seeds(seed_size)) + seeds = rank + call random_seed(put=seeds) + do n=1,size(this%bundle) + write(formatted_int,'(i0.3)')n + this%bundle(n)%field_name = "VAR"//formatted_int + allocate(this%bundle(n)%field(im,jm,this%lm)) + if (this%random) then + call random_number(this%bundle(n)%field) + else + this%bundle(n)%field = rank + end if + enddo + end subroutine + + 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 + + call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) + call MPI_Comm_Size(MPI_COMM_WORLD,comm_size,status) + allocate(this%bundle(this%num_arrays)) + ims = this%compute_decomposition(axis=1) + jms = this%compute_decomposition(axis=2) + allocate(this%i1(this%nx)) + allocate(this%in(this%nx)) + allocate(this%j1(this%ny*6)) + allocate(this%jn(this%ny*6)) + rank_counter = 0 + this%i1(1)=1 + this%j1(1)=1 + this%in(1)=ims(1) + this%jn(1)=jms(1) + + do i=2,this%nx + this%i1(i) = this%in(i-1)+1 + this%in(i) = this%in(i-1)+ims(i) + enddo + + do j=2,this%ny + this%j1(j) = this%jn(j-1)+1 + this%jn(j) = this%jn(j-1)+jms(j) + enddo + + do n=2,6 + index_offset = (n-1)*this%ny + offset = (n-1)*this%im_world + do j=1,this%ny + this%j1(j+index_offset)=this%j1(j) + offset + this%jn(j+index_offset)=this%jn(j) + offset + enddo + enddo + + do n=1,6 + do j=1,this%ny + do i=1,this%nx + if (rank == rank_counter) then + call this%allocate_n_arrays(ims(i),jms(j)) + end if + rank_counter = rank_counter + 1 + enddo + enddo + enddo + + end subroutine + + subroutine create_communicators(this) + class(test_support), intent(inout) :: this + + integer :: myid,status,nx0,ny0,color,j,ny_by_writers,local_ny,key + + local_ny = this%ny*6 + call MPI_Comm_Rank(mpi_comm_world,myid,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) + color = ny0 + call MPI_Comm_Split(MPI_COMM_WORLD,color,myid,this%xcomm,status) + + + ny_by_writers = local_ny/this%num_writers + if (mod(myid,(this%nx*local_ny)/this%num_writers) == 0) then + color = 0 + else + color = MPI_UNDEFINED + end if + call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,myid,this%writers_comm,status) + + if (this%num_writers == local_ny) then + this%gather_comm = this%xcomm + else + j = ny0 - mod(ny0-1,ny_by_writers) + call MPI_COMM_SPLIT(MPI_COMM_WORLD,j,myid,this%gather_comm,status) + end if + + call MPI_BARRIER(mpi_comm_world,status) + + + end subroutine + + subroutine close_file(this) + class(test_support), intent(inout) :: this + + integer :: status + + integer(kind=INT64) :: sub_start,sub_end + + call system_clock(count=sub_start) + + if (this%writers_comm /= MPI_COMM_NULL) then + if (this%netcdf_writes) then + status = nf90_close(this%ncid) + else + close(this%ncid) + end if + end if + call MPI_BARRIER(MPI_COMM_WORLD,status) + call system_clock(count=sub_end) + this%close_file_time = sub_end-sub_start + end subroutine + + subroutine create_file(this) + class(test_support), intent(inout) :: this + + integer :: status + integer :: info + integer :: xdim,ydim,zdim,i,varid,create_mode + character(len=:), allocatable :: fname + character(len=3) :: fc + integer(kind=INT64) :: sub_start,sub_end + integer :: y_size,writer_rank,z_chunk,chunk_factor + + call system_clock(count=sub_start) + if (this%netcdf_writes) then + + create_mode = NF90_CLOBBER + create_mode = IOR(create_mode,NF90_NETCDF4) + create_mode = IOR(create_mode,NF90_SHARE) + create_mode = IOR(create_mode,NF90_MPIIO) + call MPI_INFO_CREATE(info,status) + call MPI_INFO_SET(info,"cb_buffer_size","16777216",status) + call MPI_INFO_SET(info,"romio_cb_write","enable",status) + if (this%extra_info) then + call MPI_INFO_SET(info,"IBM_largeblock_io","true",status) + call MPI_INFO_SET(info,"striping_unit","4194304",status) + end if + if (this%writers_comm /= MPI_COMM_NULL) then + if (this%split_file) then + call MPI_COMM_RANK(this%writers_comm,writer_rank,status) + write(fc,'(I0.3)')writer_rank + fname = "checkpoint_"//fc//".nc4" + status = nf90_create(fname,ior(NF90_NETCDF4,NF90_CLOBBER), this%ncid) + chunk_factor = 1 + else + fname = "checkpoint.nc4" + status = nf90_create(fname,create_mode, this%ncid, comm=this%writers_comm, info=info) + chunk_factor = this%num_writers + end if + status = nf90_def_dim(this%ncid,"lon",this%im_world,xdim) + if (this%split_file) then + y_size = this%im_world*6/this%num_writers + else + y_size = this%im_world*6 + end if + status = nf90_def_dim(this%ncid,"lat",y_size,ydim) + status = nf90_def_dim(this%ncid,"lev",this%lm,zdim) + if (this%gather_3d) then + z_chunk = this%lm + else + z_chunk = 1 + end if + 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]) + else + status = nf90_def_var(this%ncid,this%bundle(i)%field_name,NF90_FLOAT,[xdim,ydim,zdim],varid) + end if + status = nf90_def_var_fill(this%ncid,varid,NF90_NOFILL,0) + !status = nf90_var_par_access(this%ncid,varid,NF90_COLLECTIVE) ! you can turn this on if you really want to hork up performance + enddo + status = nf90_enddef(this%ncid) + end if + else + if (this%writers_comm /= MPI_COMM_NULL) then + if (this%split_file) then + call MPI_COMM_RANK(this%writers_comm,writer_rank,status) + write(fc,'(I0.3)')writer_rank + fname = "checkpoint_"//fc//".bin" + open(file=fname,newunit=this%ncid,status='replace',form='unformatted',access='sequential') + end if + end if + end if + call MPI_BARRIER(MPI_COMM_WORLD,status) + call system_clock(count=sub_end) + this%create_file_time = sub_end-sub_start + end subroutine + + + subroutine write_file(this) + class(test_support), intent(inout) :: this + integer :: status,i,l + + integer(kind=INT64) :: sub_start,sub_end + + call MPI_BARRIER(MPI_COMM_WORLD,status) + call system_clock(count=sub_start) + call MPI_BARRIER(MPI_COMM_WORLD,status) + do i=1,this%num_arrays + if (this%gather_3d) then + call this%write_variable(this%bundle(i)%field_name,this%bundle(i)%field) + else + do l = 1,this%lm + call this%write_level(this%bundle(i)%field_name,this%bundle(i)%field(:,:,l),l) + enddo + end if + enddo + call MPI_BARRIER(MPI_COMM_WORLD,status) + call system_clock(count=sub_end) + call MPI_BARRIER(MPI_COMM_WORLD,status) + this%write_3d_time = sub_end-sub_start + call MPI_BARRIER(MPI_COMM_WORLD,status) + end subroutine + + subroutine write_variable(this,var_name,local_var) + class(test_support), intent(inout) :: this + character(len=*), intent(in) :: var_name + real, intent(in) :: local_var(:,:,:) + integer :: status + real, allocatable :: recvbuf(:) + integer :: I,J,N,K,L,myrow,myiorank,ndes_x + integer :: start(3), cnt(3) + integer :: jsize, jprev, num_io_rows + integer, allocatable :: recvcounts(:), displs(:) + integer :: im_world,jm_world,varid + real, allocatable :: var(:,:,:) + integer(kind=INT64) :: start_time,end_time,count_rate,lev,start_mpi,end_mpi + real(kind=REAL64) :: io_time + + call system_clock(count_rate=count_rate) + call system_clock(count=start_mpi) + im_world = this%im_world + jm_world = this%im_world*6 + ndes_x = size(this%in) + + call mpi_comm_rank(this%ycomm,myrow,status) + call mpi_comm_rank(this%gather_comm,myiorank,status) + call mpi_comm_size(this%gather_comm,num_io_rows,status) + num_io_rows=num_io_rows/ndes_x + + allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) + + if(myiorank==0) then + do j=1,num_io_rows + jsize = this%jn(myrow+j) - this%j1(myrow+j) + 1 + recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( this%IN - this%I1 + 1) * jsize * this%lm + enddo + + displs(1) = 0 + do i=2,ndes_x*num_io_rows + displs(i) = displs(i-1) + recvcounts(i-1) + enddo + + jsize = 0 + do j=1,num_io_rows + jsize=jsize + (this%jn(myrow+j) - this%j1(myrow+j) + 1) + enddo + allocate(VAR(IM_WORLD,jsize,this%lm), stat=status) + allocate(recvbuf(IM_WORLD*jsize*this%lm), stat=status) + end if + + if(myiorank/=0) then + allocate(recvbuf(0), stat=status) + endif + + call mpi_gatherv( local_var, size(local_var), MPI_REAL, recvbuf, recvcounts, displs, MPI_REAL, & + 0, this%gather_comm, status ) + call system_clock(count=end_mpi) + this%time_mpi = this%mpi_time + (end_mpi - start_mpi) + if (this%write_barrier) call MPI_Barrier(MPI_COMM_WORLD,status) + + if(myiorank==0) then + + jprev = 0 + k=1 + do l=1,num_io_rows + jsize = this%jn(myrow+l) - this%j1(myrow+l) + 1 + do n=1,ndes_x + do lev =1,this%lm + do j=1,jsize + do i=this%i1(n),this%in(n) + VAR(i,jprev+j,lev) = recvbuf(k) + k=k+1 + end do + end do + enddo + end do + jprev = jprev + jsize + end do + jsize=jprev + + start(1) = 1 + if (this%split_file) then + start(2) = 1 + else + start(2) = this%j1(myrow+1) + end if + start(3)= 1 + cnt(1) = IM_WORLD + cnt(2) = jsize + cnt(3) = this%lm + + call system_clock(count=start_time) + if (this%do_writes) then + if (this%netcdf_writes) then + status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + status = nf90_put_var(this%ncid,varid,var,start,cnt) + else + write(this%ncid)var + end if + end if + call system_clock(count=end_time) + this%write_counter = this%write_counter + 1 + io_time = end_time-start_time + this%data_volume = this%data_volume+byte_to_mega*4.d0*size(var,kind=INT64) + this%time_writing = this%time_writing + real(io_time,kind=REAL64)/real(count_rate,kind=REAL64) + + deallocate(VAR, stat=status) + + endif ! myiorank + + deallocate(recvbuf, stat=status) + deallocate (recvcounts, displs, stat=status) + + end subroutine + + subroutine write_level(this,var_name,local_var,z_index) + class(test_support), intent(inout) :: this + character(len=*), intent(in) :: var_name + real, intent(in) :: local_var(:,:) + integer, intent(in) :: z_index + integer :: status + real, allocatable :: recvbuf(:) + integer :: I,J,N,K,L,myrow,myiorank,ndes_x + integer :: start(3), cnt(3) + integer :: jsize, jprev, num_io_rows + integer, allocatable :: recvcounts(:), displs(:) + integer :: im_world,jm_world,varid + real, allocatable :: var(:,:) + integer(kind=INT64) :: start_time,end_time,count_rate,start_mpi,end_mpi + real(kind=REAL64) :: io_time + + call system_clock(count_rate=count_rate) + call system_clock(count=start_mpi) + im_world = this%im_world + jm_world = this%im_world*6 + ndes_x = size(this%in) + + call mpi_comm_rank(this%ycomm,myrow,status) + call mpi_comm_rank(this%gather_comm,myiorank,status) + call mpi_comm_size(this%gather_comm,num_io_rows,status) + num_io_rows=num_io_rows/ndes_x + + allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) + + if(myiorank==0) then + do j=1,num_io_rows + jsize = this%jn(myrow+j) - this%j1(myrow+j) + 1 + recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( this%IN - this%I1 + 1) * jsize + enddo + + displs(1) = 0 + do i=2,ndes_x*num_io_rows + displs(i) = displs(i-1) + recvcounts(i-1) + enddo + + jsize = 0 + do j=1,num_io_rows + jsize=jsize + (this%jn(myrow+j) - this%j1(myrow+j) + 1) + enddo + allocate(VAR(IM_WORLD,jsize), stat=status) + allocate(recvbuf(IM_WORLD*jsize), stat=status) + end if + + if(myiorank/=0) then + allocate(recvbuf(0), stat=status) + endif + + call mpi_gatherv( local_var, size(local_var), MPI_REAL, recvbuf, recvcounts, displs, MPI_REAL, & + 0, this%gather_comm, status ) + call system_clock(count=end_mpi) + this%mpi_time = this%mpi_time + (end_mpi - start_mpi) + if (this%write_barrier) call MPI_Barrier(MPI_COMM_WORLD,status) + + if(myiorank==0) then + + jprev = 0 + k=1 + do l=1,num_io_rows + jsize = this%jn(myrow+l) - this%j1(myrow+l) + 1 + do n=1,ndes_x + do j=1,jsize + do i=this%i1(n),this%in(n) + VAR(i,jprev+j) = recvbuf(k) + k=k+1 + end do + end do + end do + jprev = jprev + jsize + end do + jsize=jprev + + start(1) = 1 + if (this%split_file) then + start(2) = 1 + else + start(2) = this%j1(myrow+1) + end if + start(3)=z_index + cnt(1) = IM_WORLD + cnt(2) = jsize + cnt(3) = 1 + + call system_clock(count=start_time) + if (this%do_writes) then + if (this%netcdf_writes) then + status = nf90_inq_varid(this%ncid,name=var_name ,varid=varid) + status = nf90_put_var(this%ncid,varid,var,start,cnt) + else + write(this%ncid)var + end if + end if + call system_clock(count=end_time) + this%write_counter = this%write_counter + 1 + io_time = end_time-start_time + this%data_volume = this%data_volume+byte_to_mega*4.d0*size(var,kind=INT64) + this%time_writing = this%time_writing + real(io_time,kind=REAL64)/real(count_rate,kind=REAL64) + + deallocate(VAR, stat=status) + + endif ! myiorank + + deallocate(recvbuf, stat=status) + deallocate (recvcounts, displs, stat=status) + + end subroutine + +end module + +#include "MAPL_ErrLog.h" +program checkpoint_tester + use ESMF + use MPI + use NetCDF + use mapl_checkpoint_support_mod + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 + implicit NONE + + integer :: status,rank,writer_size,writer_rank,comm_size,i + type(test_support) :: support + integer(kind=INT64) :: start_write,end_time,count_rate,start_app,end_app + real(kind=REAL64) :: time_sum,write_time,create_time,close_time,write_3d_time,write_2d_time + real(kind=REAL64) :: application_time,data_volume + real(kind=REAL64) :: average_volume,average_time + real(kind=REAL64), allocatable :: total_throughput(:), all_proc_throughput(:) + real(kind=REAL64) :: mean_throughput, mean_fs_throughput + real(kind=REAL64) :: std_throughput, std_fs_throughput + + call system_clock(count=start_app,count_rate=count_rate) + call MPI_Init(status) + call MPI_Barrier(MPI_COMM_WORLD,status) + + call MPI_Comm_Rank(MPI_COMM_WORLD,rank,status) + call MPI_Comm_Size(MPI_COMM_WORLD,comm_size,status) + call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD) + call MPI_Barrier(MPI_COMM_WORLD,status) + + call support%set_parameters("checkpoint_benchmark.rc") + call MPI_Barrier(MPI_COMM_WORLD,status) + + call support%create_arrays() + call MPI_Barrier(MPI_COMM_WORLD,status) + + call support%create_communicators() + call MPI_Barrier(MPI_COMM_WORLD,status) + + allocate(total_throughput(support%n_trials)) + allocate(all_proc_throughput(support%n_trials)) + do i=1,support%n_trials + if (rank == 0) write(*,*)"Trial ",i + call support%reset() + + call system_clock(count=start_write) + call MPI_Barrier(MPI_COMM_WORLD,status) + call support%create_file() + call MPI_Barrier(MPI_COMM_WORLD,status) + + call support%write_file() + call MPI_Barrier(MPI_COMM_WORLD,status) + + call support%close_file() + call MPI_Barrier(MPI_COMM_WORLD,status) + + call system_clock(count=end_time) + write_time = real(end_time-start_write,kind=REAL64)/real(count_rate,kind=REAL64) + create_time = real(support%create_file_time,kind=REAL64)/real(count_rate,kind=REAL64) + write_3d_time = real(support%write_3d_time,kind=REAL64)/real(count_rate,kind=REAL64) + close_time = real(support%close_file_time,kind=REAL64)/real(count_rate,kind=REAL64) + time_sum = create_time + write_3d_time + close_time + application_time = real(end_time - start_app,kind=REAL64)/real(count_rate,kind=REAL64) + + if (support%write_counter > 0) then + call MPI_COMM_SIZE(support%writers_comm,writer_size,status) + call MPI_COMM_RANK(support%writers_comm,writer_rank,status) + call MPI_AllReduce(support%data_volume,average_volume,1,MPI_DOUBLE_PRECISION,MPI_SUM,support%writers_comm,status) + average_volume = average_volume/real(writer_size,kind=REAL64) + call MPI_AllReduce(support%time_writing,average_time,1,MPI_DOUBLE_PRECISION,MPI_SUM,support%writers_comm,status) + average_time = average_time/real(writer_size,kind=REAL64) + end if + if (rank == 0) then + total_throughput(i) = byte_to_mega*real(support%num_arrays,kind=REAL64)*real(support%im_world,kind=REAL64) & + *real(support%im_world,kind=REAL64)*6.d0*real(support%lm,kind=REAL64)*4.d0/write_3d_time + all_proc_throughput(i) = real(support%num_writers,kind=REAL32)*average_volume/average_time + end if + enddo + + call system_clock(count=end_app) + application_time = real(end_app - start_app,kind=REAL64)/real(count_rate,kind=REAL64) + if (rank == 0) then + data_volume = byte_to_mega*real(support%num_arrays,kind=REAL64)*real(support%im_world,kind=REAL64) & + *real(support%im_world,kind=REAL64)*6.d0*real(support%lm,kind=REAL64)*4.d0 + write(*,*)"***************************************************" + write(*,*)"Summary of run: " + write(*,'(A,G16.8)')"Total data volume in megabytes: ",data_volume + write(*,'(A,I3)')"Num writers: ",support%num_writers + write(*,'(A,I6)')"Total cores: ",comm_size + write(*,'(A,I6,I6)')"Cube size: ",support%im_world,support%lm + write(*,'(A,7(L1))')"Split file, 3D_gather, chunk, extra, netcdf output, write barrier, do writes: ",& + support%split_file, support%gather_3d, & + support%do_chunking,support%extra_info, & + support%netcdf_writes,support%write_barrier, support%do_writes + write(*,'(A,I6)')"Number of trial: ",support%n_trials + write(*,'(A,G16.8)')"Application time: ",application_time + end if + + if (rank == 0) then + write(*,'(A)')"Real throughput MB/s, Std Real throughput MB/s, file system MB/S, std file system MB/s" + mean_throughput = sum(total_throughput)/real(support%n_trials,kind=REAL64) + mean_fs_throughput = sum(all_proc_throughput)/real(support%n_trials,kind=REAL64) + std_throughput = 0.d0 + std_fs_throughput = 0.d0 + do i=1,support%n_trials + std_throughput = std_throughput + (total_throughput(i)-mean_throughput)**2 + std_fs_throughput = std_fs_throughput + (all_proc_throughput(i)-mean_fs_throughput)**2 + enddo + std_throughput = sqrt(std_throughput/real(support%n_trials,kind=REAL64)) + std_fs_throughput = sqrt(std_fs_throughput/real(support%n_trials,kind=REAL64)) + write(*,'(G16.8,G16.8,G16.8,G16.8)')mean_throughput,std_throughput,mean_fs_throughput,std_fs_throughput + end if + + + call MPI_Finalize(status) +end program diff --git a/cmake/CheckCompilerCapabilities.cmake b/cmake/CheckCompilerCapabilities.cmake new file mode 100644 index 000000000000..bd1b773cb7e0 --- /dev/null +++ b/cmake/CheckCompilerCapabilities.cmake @@ -0,0 +1,27 @@ +include (CheckFortranSource) + +CHECK_FORTRAN_SOURCE_COMPILE ( + ${CMAKE_CURRENT_LIST_DIR}/support_for_assumed_type.F90 + SUPPORT_FOR_ASSUMED_TYPE +) + +CHECK_FORTRAN_SOURCE_COMPILE ( + ${CMAKE_CURRENT_LIST_DIR}/support_for_c_loc_assumed_size.F90 + SUPPORT_FOR_C_LOC_ASSUMED_SIZE +) + +CHECK_FORTRAN_SOURCE_COMPILE ( + ${CMAKE_CURRENT_LIST_DIR}/support_for_mpi_alloc_mem_cptr.F90 + SUPPORT_FOR_MPI_ALLOC_MEM_CPTR + MPI +) + +CHECK_FORTRAN_SOURCE_COMPILE ( + ${CMAKE_CURRENT_LIST_DIR}/support_for_mpi_ierror_keyword.F90 + SUPPORT_FOR_MPI_IERROR_KEYWORD + MPI +) + + + + diff --git a/cmake/CheckFortranSource.cmake b/cmake/CheckFortranSource.cmake new file mode 100644 index 000000000000..3f2982abf6ec --- /dev/null +++ b/cmake/CheckFortranSource.cmake @@ -0,0 +1,83 @@ +macro (CHECK_FORTRAN_SOURCE_COMPILE file var) + + if (NOT CMAKE_REQUIRED_QUIET) + message (STATUS "Performing Test ${var}") + endif () + + if (${ARGC} GREATER 2) + try_compile ( + ${var} + ${CMAKE_BINARY_DIR} + ${file} + CMAKE_FLAGS "-DCOMPILE_DEFINITIONS:STRING=${MPI_Fortran_FLAGS}" + "-DINCLUDE_DIRECTORIES:LIST=${MPI_Fortran_INCLUDE_DIRS}" + "-DLINK_LIBRARIES:LIST=${MPI_Fortran_LIBRARIES}" + ) + else () + + try_compile ( + ${var} + ${CMAKE_BINARY_DIR} + ${file} + ) + endif () + + if (${var}) + if (NOT CMAKE_REQUIRED_QUIET) + message(STATUS "Performing Test ${var}: SUCCESS") + endif () + + add_definitions(-D${var}) + + else () + + if (NOT CMAKE_REQUIRED_QUIET) + message(STATUS "Performing Test ${var}: FAILURE") + endif () + + endif () + +endmacro (CHECK_FORTRAN_SOURCE_COMPILE) + + +macro (CHECK_FORTRAN_SOURCE_RUN file var) + + if (NOT CMAKE_REQUIRED_QUIET) + message (STATUS "Performing Test ${var}") + endif () + + try_run ( + code_runs + code_compiles + ${CMAKE_BINARY_DIR} + ${file} + ) + + if (${code_compiles}) + if (${code_runs} EQUAL 0) + + if (NOT CMAKE_REQUIRED_QUIET) + message (STATUS "Performing Test ${var}: SUCCESS") + endif () + + add_definitions(-D${var}) + + set (${var} 1) + + else () + + if (NOT CMAKE_REQUIRED_QUIET) + message (STATUS "Performing Test ${var}: RUN FAILURE") + endif () + + endif () + + else () + + if (NOT CMAKE_REQUIRED_QUIET) + message (STATUS "Performing Test ${var}: BUILD FAILURE") + endif () + + endif() + +endmacro (CHECK_FORTRAN_SOURCE_RUN) diff --git a/cmake/support_for_assumed_type.F90 b/cmake/support_for_assumed_type.F90 new file mode 100644 index 000000000000..e3e3d0868391 --- /dev/null +++ b/cmake/support_for_assumed_type.F90 @@ -0,0 +1,5 @@ +subroutine foo(x) + type(*) :: x(*) +end subroutine foo +program main +end program main diff --git a/cmake/support_for_c_loc_assumed_size.F90 b/cmake/support_for_c_loc_assumed_size.F90 new file mode 100644 index 000000000000..0d52420705f0 --- /dev/null +++ b/cmake/support_for_c_loc_assumed_size.F90 @@ -0,0 +1,10 @@ +subroutine foo(x) + use iso_c_binding + real, target :: x(*) + type (C_PTR) :: loc + loc = c_loc(x(1)) +end subroutine foo + +program main +end program main + diff --git a/cmake/support_for_mpi_alloc_mem_cptr.F90 b/cmake/support_for_mpi_alloc_mem_cptr.F90 new file mode 100644 index 000000000000..ce30fb032f48 --- /dev/null +++ b/cmake/support_for_mpi_alloc_mem_cptr.F90 @@ -0,0 +1,12 @@ +program main + use mpi + use iso_fortran_env, only: INT64 + use iso_c_binding, only: C_PTR + + integer(kind=INT64) :: sz + type (c_ptr) :: ptr + + call MPI_Alloc_mem(sz, MPI_INFO_NULL, ptr, ierror) + +end program main + diff --git a/cmake/support_for_mpi_ierror_keyword.F90 b/cmake/support_for_mpi_ierror_keyword.F90 new file mode 100644 index 000000000000..02bdaf2dcfc6 --- /dev/null +++ b/cmake/support_for_mpi_ierror_keyword.F90 @@ -0,0 +1,7 @@ +program main + use mpi + implicit none + integer :: status + call MPI_Init(ierror=status) +end program main + diff --git a/components.yaml b/components.yaml index aac5a6e23adf..970c7762769f 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.19.0 + tag: v4.20.5 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.34.0 + tag: v3.36.0 develop: develop ecbuild: diff --git a/docs/user_guide/README.md b/docs/user_guide/README.md index f696e66aad79..8cbd016827de 100644 --- a/docs/user_guide/README.md +++ b/docs/user_guide/README.md @@ -33,4 +33,6 @@ It: ### 3.8 [Miscellaneous Features: MAPL_Utils](docs/mapl_other_features.md) +### 3.9 [Automatic Code Generator](docs/mapl_code_generator.md) + ## 4 [Demos](../tutorial/README.md) diff --git a/docs/user_guide/docs/mapl_code_generator.md b/docs/user_guide/docs/mapl_code_generator.md new file mode 100644 index 000000000000..d832986e37c4 --- /dev/null +++ b/docs/user_guide/docs/mapl_code_generator.md @@ -0,0 +1,312 @@ +## MAPL Automatic Code Generator + +Any ESMF gridded component typically requires an Import State and an Export State (if necessary an Internal State too). +Each of the states contains member variables (Fields, Bundles) that need to be registered before they are used. +The number of the those variables can be large and make the declaration process cumbersome +(possibly missing fields) and the declaration section in the code extremely long. + +MAPL has a utility tool (named [MAPL_GridCompSpecs_ACG.py +](https://github.com/GEOS-ESM/MAPL/blob/main/Apps/MAPL_GridCompSpecs_ACG.py)) that simplifies and facilitates the registration and access of member variables of the various states (Export, Import, and Internal) of gridded components. +The tool relies on a formatted ASCII file (`spec`` file) to autmatically generate, at compilation time, include files that have the necessary code segments for defining and accessing the expected state member variables. +In this document, we describe the [steps](https://github.com/GEOS-ESM/MAPL/wiki/Setting-Up-MAPL-Automatic-Code-Generator) to follow to use the tool. + +To simplify this documents, we use the words _Imports_, _Exports_ and _Internals_ to refer to member variables of the Import, Export and Internal states, respectively. + +### Understanding the Issue + +Consider for instance the `MOIST` gridded component which code is available in the file [GEOS_MoistGridComp.F90](https://github.com/GEOS-ESM/GEOSgcm_GridComp/blob/develop/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90). +It has over fifty (50) _Imports_ and over five hundred (500) _Export_. +Registering (with `MAPL_AddImportSpec` and `MAPL_AddExportSpec` calls) each of them in the `SetServices` routine, requires at least seven (7) lines for the code to be readble. For instance, assume that we have: +- `PLE`, `ZLE`, and `T` as _Imports_, and +- `ZPBLCN` and `CNV_FRC` as _Exports_. + +The `SetServices` routine will then have the calls: + +```fortran +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PLE', & + LONG_NAME = 'air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'ZLE', & + LONG_NAME = 'geopotential_height', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'T', & + LONG_NAME = 'temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddExportSpec(GC, & + SHORT_NAME='ZPBLCN', & + LONG_NAME ='boundary_layer_depth', & + UNITS ='m' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddExportSpec(GC, & + SHORT_NAME='CNV_FRC', & + LONG_NAME ='convective_fraction', & + UNITS ='' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) +VERIFY_(STATUS) + +``` +Having such statements for over five hundred fifty (550) fields leads to more than thirty five hundred (3500) lines of code. +In addition, in the `Run` subroutine, we need to explicitely declare the necessary multi-dimensional arrays and access the memory location of each member variable through a `MAPL_GetPointer` call: + +```fortran +real, pointer, dimension(:,:,:) :: PLE +real, pointer, dimension(:,:,:) :: ZLE +real, pointer, dimension(:,:,:) :: T +real, pointer, dimension(:,:) :: ZPBLCN +real, pointer, dimension(:,:) :: CNV_FRC +... +... +call MAPL_GetPointer(IMPORT, PLE, 'PLE', RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(IMPORT, ZLE, 'ZLE', RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(IMPORT, T, 'T' , RC=STATUS); VERIFY_(STATUS) + +call MAPL_GetPointer(EXPORT, ZPBLCN, 'ZPBLCN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) +``` +This is at least eleven hundred (1100) lines of code. +Basically, most (over 80%) of the source code of the `MOIST` gridded component is mainly on ESMF state variable registration and access. +We want to move all the calls (`MAPL_AddImportSpec`, `MAPL_AddExportSpec`, and `MAPL_GetPointer`) and the explicit array declarations into include files to facilitate the code readability and also avoid any omission. + + +### Create the Specification (`spec`) ASCII File + +The [MAPL_GridCompSpecs_ACG.py +](https://github.com/GEOS-ESM/MAPL/blob/main/Apps/MAPL_GridCompSpecs_ACG.py) tool takes as input an ASCII specification file that has three main sections: + +1. `category: IMPORT`: for listing the _Imports_ +2. `category: EXPORT`: for listing the _Expports_ +3. `category: INTERNAL`: for listing the _Internals_ + +Each category is orgazined as a tabular data: a set of rows and columns where each row is associated with a unique field. +Columns are labelled and a column is listed only if at least one field used it. +The mandatory columns are: + +- `NAME`: name of the field as it is delared in the gridded component +- `UNIT`: unit of the field +- `DIMS`: dimensions of the field with any of the three options + - `z`: corresponding to `MAPL_DimsVertOnly` + - `xy`: corresponding to `MAPL_DimsHorzOnly` + - `xyz`: corresponding to `MAPL_DimsHorzVert` +- `VLOC`: vertical location with any of the three options: + - `C`: corresponding to `MAPL_VlocationCenter` + - `E`: corresponding to `MAPL_VlocationEdge` + - `N`: corresponding to `MAPL_VlocationNone` +- `LONG NAME`: the long name of the field (this particular column is typically the last one on the right) + +We can also add for the sake of our example here, the optional column: + +- `RESTART`: (optional and only needed for Import fileds) can have the options: + - `OPT`: `MAPL_RestartOptional` + - `SKIP`: `MAPL_RestartSkip` + - `REQ`: `MAPL_RestartRequired` + - `BOOT`: `MAPL_RestartBoot` + - `SKIPI`: `MAPL_RestartSkipInitial` + +#### Remark: +The dimensions of a field appearing in the `DIMS` column, can be listed using either the short name, say `z`, or the corresponding MAPL name, say `MAPL_DimsVertOnly`. + +More column options are listed in the file: [MAPL_GridCompSpecs_ACG.py +](https://github.com/GEOS-ESM/MAPL/blob/main/Apps/MAPL_GridCompSpecs_ACG.py). + +Assume that we create such a file (that we name `MyComponent_StateSpecs.rc`) and include the fields used in the previous section. +`MyComponent_StateSpecs.rc` looks like: + + +``` +component: MyComponent + +category: IMPORT +#---------------------------------------------------------------------------- +# VARIABLE | DIMENSIONS | Additional Metadata +#---------------------------------------------------------------------------- + NAME | UNITS | DIMS | VLOC | RESTART | LONG NAME +#---------------------------------------------------------------------------- + ZLE | m | xyz | E | | geopotential_height + T | K | xyz | C | OPT | air_temperature + PLE | Pa | xyz | E | OPT | air_pressure + +category: EXPORT +#--------------------------------------------------------------------------- +# VARIABLE | DIMENSIONS | Additional Metadata +#--------------------------------------------------------------------------- + NAME | UNITS | DIMS | VLOC | LONG NAME +#--------------------------------------------------------------------------- + ZPBLCN | m | xy | N | boundary_layer_depth + CNV_FRC | | xy | N | convective_fraction + +category: INTERNAL +#--------------------------------------------------------------------------- +# VARIABLE | DIMENSION | Additional Metadata +#--------------------------------------------------------------------------- + NAME | UNITS | DIMS | VLOC | ADD2EXPORT | FRIENDLYTO | LONG NAME +#--------------------------------------------------------------------------- + + +#******************************************************** +# +# Legend +# +#------------------------------------------------------------------ +# Column label | MAPL keyword/interpretation | Default +#--------------|--------------------------------------------------- +# NAME | short_name | +# UNITS | units | +# DIMS | dims | +# VLOC | VLocation | MAPL_VLocationNone +# LONG NAME | long_name | +# COND | if () then | .FALSE. +# NUM_SUBTILES | num_subtiles +# ... +#------------------------------------------------------------------ +# +#-------------------------------------------- +# Entry alias | Column | MAPL keyword/interpretation +#--------------|----------------------------- +# xyz | DIMS | MAPL_HorzVert +# xy | DIMS | MAPL_HorzOnly +# z | DIMS | MAPL_VertOnly (plus ungridded) +# C | VLOC | MAPL_VlocationCenter +# E | VLOC | MAPL_VlocationEdge +# N | VLOC | MAPL_VlocationNone +#-------------------------------------------- +``` + +Running `MAPL_GridCompSpecs_ACG.py` on the file `MyComponent_StateSpecs.rc` generates at compilation time four (4) includes files: + +1. `MyComponent_Export___.h` for the `MAPL_AddExportSpec` calls in the `SetServices` routine: + + +``` +call MAPL_AddExportSpec(GC, & + SHORT_NAME='ZPBLCN', & + LONG_NAME ='boundary_layer_depth', & + UNITS ='m' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddExportSpec(GC, & + SHORT_NAME='CNV_FRC', & + LONG_NAME ='convective_fraction', & + UNITS ='' , & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) +VERIFY_(STATUS) +``` + +2. `MyComponent_Import___.h` for the `MAPL_AddImportSpec` calls in the `SetServices` routine: + +```fortran +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'PLE', & + LONG_NAME = 'air_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'ZLE', & + LONG_NAME = 'geopotential_height', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationEdge, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) + +call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'T', & + LONG_NAME = 'temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, & + AVERAGING_INTERVAL = AVRGNINT, & + REFRESH_INTERVAL = RFRSHINT, RC=STATUS ) +VERIFY_(STATUS) +``` + +3. `MyComponent_DeclarePointer___.h` contains all the multi-dimensional array (associated with each field used the the various states) delarations in the `Run` method (the `#include MyComponent_DeclarePointer___.h` statement should be the line of the local declaration variable declarion section): + +```fortran +real, pointer, dimension(:,:,:) :: PLE +real, pointer, dimension(:,:,:) :: ZLE +real, pointer, dimension(:,:,:) :: T +real, pointer, dimension(:,:) :: ZPBLCN +real, pointer, dimension(:,:) :: CNV_FRC +``` + +4. `MyComponent_GetPointer___.h` contains all the `MAPL_GetPointer` calls in the `Run` method (the `#include MyComponent_GetPointer___.h` statement needs to be placed well before any field is accessed): + +```fortran +call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(IMPORT, ZLE, 'ZLE' , RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(IMPORT, T, 'T' , RC=STATUS); VERIFY_(STATUS) + +call MAPL_GetPointer(EXPORT, ZPBLCN, 'ZPBLCN' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) +call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) +``` + + + +### Edit the Source Code + +In the `SetServices` routine, all the `MAPL_AddExportSpec` and `MAPL_AddImportSpec` calls for the variables listed in the `MyComponent_StateSpecs.rc` need to be removed and replaced with the two lines just after the declaration of the local variables: +``` +... +#include "MyComponent_Export___.h" +#include "MyComponent_Import___.h" +... +``` + +Similarly in the `Run` routine, the array declaration section and the `MAPL_GetPointer` calls are removed and replaced with the lines: +``` +... +#include "MyComponent_DeclarePointer___.h" +... +#include "MyComponent_GetPointer___.h" +... +``` + +### Edit the `CMakeLists.txt` File + +The following lines need to be added in the `CMakeLists.txt` file: + +``` +mapl_acg (${this} MyComponent_StateSpecs.rc + IMPORT_SPECS EXPORT_SPECS INTERNAL_SPECS + GET_POINTERS DECLARE_POINTERS) +``` + +Note, if in your case, there is no Internal state, `INTERNAL_SPECS` needs not to be added in the above command. But there is no harm including it. + +### Future Work + +A future version of the tool will support a YAML specification file. diff --git a/field_utils/FieldBLAS.F90 b/field_utils/FieldBLAS.F90 index e7cbd7dd7fd7..f4ad9b582ee1 100644 --- a/field_utils/FieldBLAS.F90 +++ b/field_utils/FieldBLAS.F90 @@ -4,8 +4,6 @@ module mapl_FieldBLAS use ESMF use MAPL_ExceptionHandling use MAPL_FieldPointerUtilities - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 - use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 implicit none private diff --git a/field_utils/FieldBinaryOperations.F90 b/field_utils/FieldBinaryOperations.F90 index 3b4bbff8f706..3d1f48da9661 100644 --- a/field_utils/FieldBinaryOperations.F90 +++ b/field_utils/FieldBinaryOperations.F90 @@ -4,7 +4,6 @@ module MAPL_FieldBinaryOperations use ESMF use MAPL_ExceptionHandling use MAPL_FieldPointerUtilities - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private diff --git a/field_utils/FieldPointerUtilities.F90 b/field_utils/FieldPointerUtilities.F90 index aa6cdddd3a11..fc5cb8ca1323 100644 --- a/field_utils/FieldPointerUtilities.F90 +++ b/field_utils/FieldPointerUtilities.F90 @@ -3,8 +3,6 @@ module MAPL_FieldPointerUtilities use ESMF use MAPL_ExceptionHandling - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 - use, intrinsic :: iso_fortran_env, only: INT8, INT16, INT32, INT64 implicit none private diff --git a/field_utils/FieldUnaryFunctions.F90 b/field_utils/FieldUnaryFunctions.F90 index 1cba7b968c3f..e1b136f5a36c 100644 --- a/field_utils/FieldUnaryFunctions.F90 +++ b/field_utils/FieldUnaryFunctions.F90 @@ -4,7 +4,6 @@ module MAPL_FieldUnaryFunctions use ESMF use MAPL_ExceptionHandling use MAPL_FieldPointerUtilities - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private diff --git a/generic/AbstractComponent.F90 b/generic/AbstractComponent.F90 index eb02ea5d9950..094333e88616 100644 --- a/generic/AbstractComponent.F90 +++ b/generic/AbstractComponent.F90 @@ -96,7 +96,7 @@ subroutine i_RunChild(this, name, clock, phase, unusable, rc) end subroutine i_RunChild subroutine i_SetLogger(this, logger) - use pFlogger, only: t_Logger => Logger + use pfl_logger, only: t_Logger => Logger import AbstractComponent implicit none class(AbstractComponent), intent(inout) :: this @@ -105,7 +105,7 @@ subroutine i_SetLogger(this, logger) end subroutine i_SetLogger function i_GetLogger(this) result(logger) - use pFlogger, only: t_Logger => Logger + use pfl_logger, only: t_Logger => Logger import AbstractComponent implicit none class(t_Logger), pointer :: logger diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 319efca86183..fe19ebff2c3f 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -2019,14 +2019,12 @@ subroutine capture(POS, PHASE, GC, IMPORT, EXPORT, CLOCK, RC) write(phase_, '(i1)') phase call MAPL_ESMFStateWriteToFile(import, CLOCK, trim(FILENAME)//"import_"//trim(POS)//"_runPhase"//phase_, & - FILETYPE, STATE, .false., _RC) - + FILETYPE, STATE, .false., state%grid%write_restart_by_oserver, _RC) call MAPL_ESMFStateWriteToFile(export, CLOCK, trim(FILENAME)//"export_"//trim(POS)//"_runPhase"//phase_, & - FILETYPE, STATE, .false., oClients = o_Clients, _RC) - + FILETYPE, STATE, .false., state%grid%write_restart_by_oserver, _RC) call MAPL_GetResource(STATE, hdr, default=0, LABEL="INTERNAL_HEADER:", _RC) call MAPL_ESMFStateWriteToFile(internal, CLOCK, trim(FILENAME)//"internal_"//trim(POS)//"_runPhase"//phase_, & - FILETYPE, STATE, hdr/=0, oClients = o_Clients, _RC) + FILETYPE, STATE, hdr/=0, state%grid%write_restart_by_oserver, _RC) end if _RETURN(_SUCCESS) end subroutine capture @@ -2407,7 +2405,7 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(status) internal_state => state%get_internal_state() call MAPL_ESMFStateWriteToFile(internal_state,CLOCK,FILENAME, & - FILETYPE, STATE, hdr/=0, oClients = o_Clients, RC=status) + FILETYPE, STATE, hdr/=0, state%grid%write_restart_by_oserver, RC=status) _VERIFY(status) endif @@ -2431,7 +2429,7 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) endif #endif call MAPL_ESMFStateWriteToFile(IMPORT,CLOCK,FILENAME, & - FILETYPE, STATE, .FALSE., oClients = o_Clients, RC=status) + FILETYPE, STATE, .FALSE., state%grid%write_restart_by_oserver, RC=status) _VERIFY(status) endif @@ -2486,7 +2484,7 @@ subroutine checkpoint_export_state(rc) endif #endif call MAPL_ESMFStateWriteToFile(EXPORT,CLOCK,FILENAME, & - FILETYPE, STATE, .FALSE., oClients = o_Clients, RC=status) + FILETYPE, STATE, .FALSE., state%grid%write_restart_by_oserver, RC=status) _VERIFY(status) endif _RETURN(_SUCCESS) @@ -2772,7 +2770,7 @@ subroutine MAPL_StateRecord( GC, IMPORT, EXPORT, CLOCK, RC ) end if call MAPL_ESMFStateWriteToFile(IMPORT, CLOCK, & STATE%RECORD%IMP_FNAME, & - FILETYPE, STATE, .FALSE., oClients = o_Clients, & + FILETYPE, STATE, .FALSE., state%grid%write_restart_by_oserver, & RC=status) _VERIFY(status) end if @@ -2789,7 +2787,7 @@ subroutine MAPL_StateRecord( GC, IMPORT, EXPORT, CLOCK, RC ) internal_state => STATE%get_internal_state() call MAPL_ESMFStateWriteToFile(internal_state, CLOCK, & STATE%RECORD%INT_FNAME, & - FILETYPE, STATE, hdr/=0, oClients = o_Clients, & + FILETYPE, STATE, hdr/=0, state%grid%write_restart_by_oserver, & RC=status) _VERIFY(status) end if @@ -5737,14 +5735,14 @@ end subroutine MAPL_GenericStateClockAdd !============================================================================= !============================================================================= - subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oClients,RC) + subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, write_with_oserver,RC) type(ESMF_State), intent(INOUT) :: STATE type(ESMF_Clock), intent(IN ) :: CLOCK character(len=*), intent(IN ) :: FILENAME character(LEN=*), intent(INout) :: FILETYPE type(MAPL_MetaComp), intent(INOUT) :: MPL logical, intent(IN ) :: HDR - type (ClientManager), optional, intent(inout) :: oClients + logical, optional, intent(in ) :: write_with_oserver integer, optional, intent( OUT) :: RC character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_ESMFStateWriteToFile" @@ -5774,7 +5772,10 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli !real(kind=ESMF_KIND_R8),save :: total_time = 0.0d0 !logical :: amIRoot !type (ESMF_VM) :: vm - logical :: empty + logical :: empty, local_write_with_oserver + + local_write_with_oserver=.false. + if (present(write_with_oserver)) local_write_with_oserver = write_with_oserver ! Check if state is empty. If "yes", simply return empty = MAPL_IsStateEmpty(state, _RC) @@ -5991,8 +5992,11 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli !itime_beg = MPI_Wtime() !_VERIFY(status) - call MAPL_VarWriteNCPar(filename,STATE,ArrDes,CLOCK, oClients=oClients, RC=status) - _VERIFY(status) + if (local_write_with_oserver) then + call MAPL_VarWriteNCPar(filename,STATE,ArrDes,CLOCK, oClients=o_clients, _RC) + else + call MAPL_VarWriteNCPar(filename,STATE,ArrDes,CLOCK, _RC) + end if !call MPI_Barrier(mpl%grid%comm, status) !_VERIFY(status) @@ -10496,7 +10500,7 @@ recursive subroutine MAPL_GenericStateSave( GC, IMPORT, EXPORT, CLOCK, RC ) end if call MAPL_ESMFStateWriteToFile(IMPORT, CLOCK, & STATE%initial_state%IMP_FNAME, & - CFILETYPE, STATE, .FALSE., oClients = o_Clients, & + CFILETYPE, STATE, .FALSE., write_with_oserver = state%grid%write_restart_by_oserver, & RC=status) _VERIFY(status) end if @@ -10512,7 +10516,7 @@ recursive subroutine MAPL_GenericStateSave( GC, IMPORT, EXPORT, CLOCK, RC ) internal_state => STATE%get_internal_state() call MAPL_ESMFStateWriteToFile(internal_state, CLOCK, & STATE%initial_state%INT_FNAME, & - CFILETYPE, STATE, hdr/=0, oClients = o_Clients, & + CFILETYPE, STATE, hdr/=0, write_with_oserver = state%grid%write_restart_by_oserver, & RC=status) _VERIFY(status) end if diff --git a/gridcomps/Cap/FargparseCLI.F90 b/gridcomps/Cap/FargparseCLI.F90 index 68360a1b0a5f..48d6b5de335c 100644 --- a/gridcomps/Cap/FargparseCLI.F90 +++ b/gridcomps/Cap/FargparseCLI.F90 @@ -77,7 +77,8 @@ function new_CapOptions_from_fargparse_back_comp(unusable, extra, rc) result (fa integer, optional, intent(out) :: rc integer :: status - fargparsecap%parser = ArgParser() + call fargparsecap%parser%initialize('executable') + call fargparsecap%add_command_line_options(fargparsecap%parser, _RC) diff --git a/gridcomps/ExtData/ExtDataGridCompMod.F90 b/gridcomps/ExtData/ExtDataGridCompMod.F90 index 7caaaf0ba61b..729ef9b78559 100644 --- a/gridcomps/ExtData/ExtDataGridCompMod.F90 +++ b/gridcomps/ExtData/ExtDataGridCompMod.F90 @@ -313,9 +313,9 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_GridComp), intent(inout) :: GC !! Grid Component type(ESMF_State), intent(inout) :: IMPORT !! Import State type(ESMF_State), intent(inout) :: EXPORT !! Export State - integer, intent(out) :: rc !! Error return code: - !! 0 - all is well - !! 1 - + integer, intent(out) :: rc !! Error return code: + !! 0 - all is well + !! 1 - ! !------------------------------------------------------------------------- @@ -1196,9 +1196,9 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_GridComp), intent(inout) :: GC !! Grid Component type(ESMF_State), intent(inout) :: IMPORT !! Import State type(ESMF_State), intent(inout) :: EXPORT !! Export State - integer, intent(out) :: rc !! Error return code: - !! 0 - all is well - !! 1 - + integer, intent(out) :: rc !! Error return code: + !! 0 - all is well + !! 1 - ! !------------------------------------------------------------------------- @@ -1600,9 +1600,9 @@ SUBROUTINE Finalize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_GridComp), intent(inout) :: GC !! Grid Component type(ESMF_State), intent(inout) :: IMPORT !! Import State type(ESMF_State), intent(inout) :: EXPORT !! Export State - integer, intent(out) :: rc !! Error return code: - !! 0 - all is well - !! 1 - + integer, intent(out) :: rc !! Error return code: + !! 0 - all is well + !! 1 - ! !------------------------------------------------------------------------- @@ -3760,14 +3760,14 @@ end subroutine MAPL_ExtDataEvaluateMask ! extracts integers from a character-delimited string, for example, "-1,45,256,7,10". In the context ! of Chem_Util, this is provided for determining the numerically indexed regions over which an ! emission might be applied. -! +! ! In multiple passes, the string is parsed for the delimiter, and the characters up to, but not ! including the delimiter are taken as consecutive digits of an integer. A negative sign ("-") is ! allowed. After the first pass, each integer and its trailing delimiter are lopped of the head of ! the (local copy of the) string, and the process is started over. ! ! The default delimiter is a comma (","). -! +! ! "Unfilled" iValues are zero. ! ! Return codes: @@ -3776,7 +3776,7 @@ end subroutine MAPL_ExtDataEvaluateMask ! ! @bug !-The routine works under the following assumptions: -!- A non-zero return code does not stop execution. +!- A non-zero return code does not stop execution. !- Allowed numerals are: 0,1,2,3,4,5,6,7,8,9. !- A delimiter must be separated from another delimiter by at least one numeral. !- The delimiter cannot be a numeral or a negative sign. @@ -3789,9 +3789,9 @@ end subroutine MAPL_ExtDataEvaluateMask ! Examples of strings that will work: !``` ! "1" -! "-1" +! "-1" ! "-1,2004,-3" -! "1+-2+3" +! "1+-2+3" ! "-1A100A5" !``` ! @@ -4454,15 +4454,6 @@ subroutine MAPL_ExtDataPopulateBundle(item,filec,pbundle,rc) call MAPL_FieldBundleAdd(pbundle,Field2,rc=status) _VERIFY(STATUS) - !block - !character(len=ESMF_MAXSTR) :: vectorlist(2) - !vectorlist(1) = item%fcomp1 - !vectorlist(2) = item%fcomp2 - !call ESMF_AttributeSet(pbundle,name="VectorList:", itemCount=2, & - !valuelist = vectorlist, rc=status) - !_VERIFY(STATUS) - !end block - else if (item%do_Fill .or. item%do_VertInterp) then diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index aba380203f23..d9356e9bb70c 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -668,7 +668,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) match = .false. contLine = .false. con3 = .false. - + do while (.true.) read(unitr, '(A)', end=1234) line j = index( adjustl(line), trim(adjustl(string)) ) @@ -677,7 +677,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) j = index(line, trim(string)//'fields:') contLine = (j > 0) k = index(line, trim(string)//'obs_files:') - con3 = (k > 0) + con3 = (k > 0) end if if (match .or. contLine .or. con3) then write(unitw,'(A)') trim(line) @@ -686,7 +686,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (adjustl(line) == '::') contLine = .false. end if if (con3) then - if (adjustl(line) == '::') con3 = .false. + if (adjustl(line) == '::') con3 = .false. endif end do @@ -883,7 +883,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigGetDim(cfg, nline, ncol, label=trim(string)//'obs_files:', rc=rc) ! here donot check rc on purpose if (rc==0) then if (nline > 0) then - list(n)%timeseries_output = .true. + list(n)%timeseries_output = .true. endif endif call ESMF_ConfigGetAttribute(cfg, value=list(n)%recycle_track, default=.false., & @@ -2449,7 +2449,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) print *, ' End_Date: ', list(n)%end_date print *, ' End_Time: ', list(n)%end_time endif - print *, ' Regrid Mthd: ', regrid_method_int_to_string(list(n)%regrid_method) + if (trim(list(n)%output_grid_label)/='') then + print *, ' Regrid Mthd: ', regrid_method_int_to_string(list(n)%regrid_method) + else + print *, ' Regrid Mthd: ', 'identity' + end if + block integer :: im_world, jm_world,dims(3) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 95a4ca60d346..012c3ba6b48d 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -44,7 +44,7 @@ call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(string)//'Epoch:', default=0, _RC) _ASSERT(time_integer /= 0, 'Epoch value in config wrong') - call hms_2_s (time_integer, second, _RC) + second = hms_2_s(time_integer) call ESMF_TimeIntervalSet(epoch_frequency, s=second, _RC) traj%Epoch = time_integer traj%RingTime = currTime @@ -545,7 +545,7 @@ timeset(1) = current_time timeset(2) = current_time + this%epoch_frequency call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) - call hms_2_s (this%Epoch, sec, _RC) + sec = hms_2_s(this%Epoch) j1 = j0 + int(sec, kind=ESMF_KIND_I8) jx0 = real ( j0, kind=ESMF_KIND_R8) jx1 = real ( j1, kind=ESMF_KIND_R8) @@ -1152,7 +1152,7 @@ len = size (this%times_R8) do i=1, len int_time = this%times_R8(i) - call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, time0, time1=time1, tunit=tunit, _RC) + call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, time0, time=time1, time_unit=tunit, _RC) this%times(i) = time1 enddo diff --git a/include/MAPL_ErrLog.h b/include/MAPL_ErrLog.h index 6dfa6d82626a..e863c1777b3f 100644 --- a/include/MAPL_ErrLog.h +++ b/include/MAPL_ErrLog.h @@ -111,7 +111,11 @@ # define _RC _RC_(rc,status) # define _STAT _RC_(stat,status) +#if defined(SUPPORT_FOR_MPI_IERROR_KEYWORD) # define _IERROR _RC_(ierror,status) +#else +# define _IERROR _RC_(ierr,status) +#endif # define _IOSTAT _RC_(iostat,status) # define _ASSERT_MSG_AND_LOC_AND_RC(A,msg,stat,file,line,rc) if(MAPL_Assert(A,msg,stat,file,line __rc(rc))) __return diff --git a/include/unused_dummy.H b/include/unused_dummy.H index 91337aca862c..6d7063924148 100644 --- a/include/unused_dummy.H +++ b/include/unused_dummy.H @@ -10,4 +10,4 @@ #ifdef _UNUSED_DUMMY # undef _UNUSED_DUMMY #endif -#define _UNUSED_DUMMY(x) if (.false.) print*,shape(x) +#define _UNUSED_DUMMY(x) if (.false.) then; associate (q____ => x); end associate; endif diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 710718284280..6af1d06b6d7d 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -133,6 +133,10 @@ 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/DirectoryService.F90 b/pfio/DirectoryService.F90 index 6f4471ae0c19..325beb523acb 100644 --- a/pfio/DirectoryService.F90 +++ b/pfio/DirectoryService.F90 @@ -40,7 +40,7 @@ module pFIO_DirectoryServiceMod integer, parameter :: DISCOVERY_TAG = 1 ! Exchange of _root_ rank between client and server integer, parameter :: NPES_TAG = 2 ! Client sends number of pes in client to server (on roots) integer, parameter :: RANKS_TAG = 3 ! Client sends ranks of client processes to server (on roots) - integer, parameter :: CONNECT_TAG = 3 ! client and server individual processes exchange ranks + integer, parameter :: CONNECT_TAG = 3 ! client and server individual processes exchange ranks type :: DirectoryEntry sequence @@ -90,7 +90,7 @@ function new_DirectoryService(comm, unusable, rc) result(ds) integer, intent(in) :: comm class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + integer :: ierror type (Directory) :: empty_dir @@ -118,7 +118,7 @@ function new_DirectoryService(comm, unusable, rc) result(ds) _UNUSED_DUMMY(unusable) end function new_DirectoryService - + integer function make_directory_window(comm, addr) result(win) integer, intent(in) :: comm type (c_ptr), intent(out) :: addr @@ -126,13 +126,21 @@ integer function make_directory_window(comm, addr) result(win) type (Directory), pointer :: dir type (Directory), target :: dirnull integer(kind=MPI_ADDRESS_KIND) :: sz +#if !defined (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) + integer(kind=MPI_ADDRESS_KIND) :: baseaddr +#endif integer :: ierror, rank call MPI_Comm_Rank(comm, rank, ierror) if (rank == 0) then sz = sizeof_directory() +#if defined(SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) call MPI_Alloc_mem(sz, MPI_INFO_NULL, addr, ierror) +#else + call MPI_Alloc_mem(sz, MPI_INFO_NULL, baseaddr, ierror) + addr = transfer(baseaddr, addr) +#endif call c_f_pointer(addr, dir) else sz = 0 @@ -142,7 +150,7 @@ integer function make_directory_window(comm, addr) result(win) call MPI_Win_create(dir, sz, 1, MPI_INFO_NULL, comm, win, ierror) end function make_directory_window - + subroutine connect_to_server(this, port_name, client, client_comm, unusable, server_size, rc) use pFIO_ClientThreadMod class (DirectoryService), target, intent(inout) :: this @@ -170,7 +178,7 @@ subroutine connect_to_server(this, port_name, client, client_comm, unusable, ser integer :: server_npes integer, allocatable :: client_ranks(:) integer, allocatable :: server_ranks(:) - + class(ServerThread), pointer :: server_thread_ptr class(BaseServer), pointer :: server_ptr type(SimpleSocket), target :: ss @@ -226,7 +234,7 @@ subroutine connect_to_server(this, port_name, client, client_comm, unusable, ser call MPI_Comm_rank(this%comm, dir_entry%partner_root_rank, ierror) ! global comm dir%entries(n) = dir_entry - + call this%put_directory(dir, this%win_client_directory) end if @@ -262,7 +270,7 @@ subroutine connect_to_server(this, port_name, client, client_comm, unusable, ser call MPI_Scatter(server_ranks, 1, MPI_INTEGER, & & server_rank, 1, MPI_INTEGER, & & 0, client_comm, ierror) - + if (present(server_size)) call MPI_Bcast(server_size, 1, MPI_INTEGER, 0, client_comm,ierror) ! Construct the connection @@ -341,7 +349,7 @@ subroutine connect_to_client(this, port_name, server, rc) end if call this%mutex%release() - + if (found) then call MPI_Send(this%rank, 1, MPI_INTEGER, client_root_rank, DISCOVERY_TAG, this%comm, ierror) else @@ -418,11 +426,11 @@ subroutine publish(this, port, server, rc) type(PortInfo),target, intent(in) :: port class (BaseServer), intent(inout) :: server integer, optional, intent(out) :: rc - character(len=MAX_LEN_PORT_NAME) :: port_name + character(len=MAX_LEN_PORT_NAME) :: port_name integer :: ierror integer :: rank_in_server integer :: n - + type (Directory) :: dir type (DirectoryEntry) :: dir_entry @@ -464,7 +472,7 @@ subroutine publish(this, port, server, rc) n = dir%num_entries + 1 dir%num_entries = n - + dir_entry%port_name = port_name dir_entry%partner_root_rank = this%rank dir%entries(n) = dir_entry @@ -478,14 +486,14 @@ end subroutine publish function sizeof_directory() result(sz) integer :: sz - + integer :: sizeof_char, sizeof_integer, sizeof_DirectoryEntry integer :: one_integer character :: one_char sizeof_integer = c_sizeof(one_integer) sizeof_char = c_sizeof(one_char) - + sizeof_DirectoryEntry = MAX_LEN_PORT_NAME*sizeof_char + 1*sizeof_integer sz = sizeof_integer + MAX_NUM_PORTS*sizeof_DirectoryEntry end function sizeof_directory @@ -524,7 +532,7 @@ function get_directory(this, win) result(dir) return _UNUSED_DUMMY(this) end function get_directory - + subroutine put_directory(this, dir, win) class (DirectoryService), intent(in) :: this @@ -546,7 +554,7 @@ subroutine put_directory(this, dir, win) return _UNUSED_DUMMY(this) end subroutine put_directory - + subroutine terminate_servers(this, client_comm, rc) class (DirectoryService), intent(inout) :: this integer ,intent(in) :: client_comm @@ -554,13 +562,13 @@ subroutine terminate_servers(this, client_comm, rc) type (Directory) :: dir integer :: ierror, rank_in_client,i - + call MPI_Comm_rank(client_comm, rank_in_client, ierror) call MPI_BARRIER(client_comm,ierror) if (rank_in_client ==0) then - + write(6,*)"client0 terminates servers"; flush(6) dir = this%get_directory(this%win_server_directory) diff --git a/pfio/MpiMutex.F90 b/pfio/MpiMutex.F90 index cd3cce16780e..956638ef2102 100644 --- a/pfio/MpiMutex.F90 +++ b/pfio/MpiMutex.F90 @@ -39,6 +39,9 @@ function new_MpiMutex(comm) result(lock) integer :: ierror integer(kind=MPI_ADDRESS_KIND) :: sz +#if !defined (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) + integer(kind=MPI_ADDRESS_KIND) :: baseaddr +#endif call MPI_Comm_dup(comm, lock%comm, ierror) call MPI_Comm_rank(lock%comm, lock%rank, ierror) @@ -61,10 +64,15 @@ function new_MpiMutex(comm) result(lock) block logical, pointer :: scratchpad(:) integer :: sizeof_logical - + call MPI_Type_extent(MPI_LOGICAL, sizeof_logical, ierror) sz = lock%npes * sizeof_logical +#if defined(SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) call MPI_Alloc_mem(sz, MPI_INFO_NULL, lock%locks_ptr, ierror) +#else + call MPI_Alloc_mem(sz, MPI_INFO_NULL, baseaddr, ierror) + lock%locks_ptr = transfer(baseaddr, lock%locks_ptr) +#endif call c_f_pointer(lock%locks_ptr, scratchpad, [lock%npes]) scratchpad = .false. @@ -144,7 +152,7 @@ subroutine release(this) end if end do end if - + if (next_rank /= -1) then call MPI_Send(buffer, 0, MPI_LOGICAL, next_rank, & & LOCK_TAG, this%comm, ierror) diff --git a/pfio/RDMAReference.F90 b/pfio/RDMAReference.F90 index f692b4230a56..5b556391188a 100644 --- a/pfio/RDMAReference.F90 +++ b/pfio/RDMAReference.F90 @@ -16,8 +16,8 @@ module pFIO_RDMAReferenceMod public :: RDMAReference type,extends(AbstractDataReference) :: RDMAReference - integer :: win - integer :: comm + integer :: win + integer :: comm integer :: mem_rank integer(kind=INT64) :: msize_word logical :: RDMA_allocated = .false. @@ -106,7 +106,7 @@ subroutine deserialize(this, buffer, rc) _VERIFY(status) _RETURN(_SUCCESS) end subroutine deserialize - + subroutine allocate(this, rc) class (RDMAReference), intent(inout) :: this integer, optional, intent(out) :: rc @@ -114,22 +114,32 @@ subroutine allocate(this, rc) integer :: disp_unit,status, Rank integer(kind=MPI_ADDRESS_KIND) :: n_bytes integer :: int_size - +#if !defined (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) + integer(kind=MPI_ADDRESS_KIND) :: baseaddr +#endif + int_size = c_sizeof(int_size) disp_unit = int_size n_bytes = this%msize_word * int_size call MPI_Comm_rank(this%comm,Rank,status) - windowsize = 0_MPI_ADDRESS_KIND + windowsize = 0_MPI_ADDRESS_KIND if (Rank == this%mem_rank) windowsize = n_bytes - + +#if defined (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) call MPI_Win_allocate(windowsize, disp_unit, MPI_INFO_NULL, this%comm, & this%base_address, this%win, status) _VERIFY(status) +#else + call MPI_Win_allocate(windowsize, disp_unit, MPI_INFO_NULL, this%comm, & + baseaddr, this%win, status) + _VERIFY(status) + this%base_address = transfer(baseaddr, this%base_address) +#endif call MPI_Win_fence(0, this%win, status) _VERIFY(status) - + this%RDMA_allocated = .true. _RETURN(_SUCCESS) end subroutine allocate diff --git a/pfio/ShmemReference.F90 b/pfio/ShmemReference.F90 index e7e9e228d1d5..b71ced10ea91 100644 --- a/pfio/ShmemReference.F90 +++ b/pfio/ShmemReference.F90 @@ -72,7 +72,7 @@ subroutine serialize(this, buffer,rc) if(allocated(buffer)) deallocate(buffer) allocate(buffer(this%get_length())) - + call this%serialize_base(tmp_buff, rc=status) _VERIFY(status) n = this%get_length_base() @@ -102,7 +102,7 @@ subroutine deserialize(this, buffer, rc) _VERIFY(status) _RETURN(_SUCCESS) end subroutine deserialize - + subroutine allocate(this, rc) class (ShmemReference), intent(inout) :: this integer, optional, intent(out) :: rc @@ -110,22 +110,36 @@ subroutine allocate(this, rc) integer(kind=MPI_ADDRESS_KIND) :: windowsize integer :: disp_unit,ierr, InNode_Rank integer(kind=MPI_ADDRESS_KIND) :: n_bytes +#if !defined (SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) + integer(kind=MPI_ADDRESS_KIND) :: baseaddr +#endif n_bytes = this%msize_word * 4_MPI_ADDRESS_KIND call MPI_Comm_rank(this%InNode_Comm,InNode_Rank,ierr) disp_unit = 1 - windowsize = 0_MPI_ADDRESS_KIND + windowsize = 0_MPI_ADDRESS_KIND if (InNode_Rank == 0) windowsize = n_bytes - + +#if defined(SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) call MPI_Win_allocate_shared(windowsize, disp_unit, MPI_INFO_NULL, this%InNode_Comm, & this%base_address, this%win, ierr) +#else + call MPI_Win_allocate_shared(windowsize, disp_unit, MPI_INFO_NULL, this%InNode_Comm, & + baseaddr, this%win, ierr) + this%base_address = transfer(baseaddr, this%base_address) +#endif if (InNode_Rank /= 0) then +#if defined(SUPPORT_FOR_MPI_ALLOC_MEM_CPTR) call MPI_Win_shared_query(this%win, 0, windowsize, disp_unit, this%base_address,ierr) +#else + call MPI_Win_shared_query(this%win, 0, windowsize, disp_unit, baseaddr,ierr) + this%base_address = transfer(baseaddr, this%base_address) +#endif endif - + this%shmem_allocated = .true. _RETURN(_SUCCESS) end subroutine allocate diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 637e0f615ea8..94f9336e8c79 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -28,6 +28,7 @@ set (srcs DownBit.F90 ShaveMantissa.c MAPL_Sleep.F90 + MAPL_CF_Time.F90 # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 diff --git a/shared/MAPL_CF_Time.F90 b/shared/MAPL_CF_Time.F90 new file mode 100644 index 000000000000..c6b48b43d9e8 --- /dev/null +++ b/shared/MAPL_CF_Time.F90 @@ -0,0 +1,505 @@ +#include "MAPL_Exceptions.h" +#include "MAPL_ErrLog.h" +module MAPL_CF_Time + + use, intrinsic :: iso_fortran_env, only : R64 => real64 + use MAPL_KeywordEnforcerMod + use MAPL_ExceptionHandling + use MAPL_DateTime_Parsing + + implicit none + +! Comment to test all procedures + private + +! PUBLIC PROCEDURES (ACCESS): + public :: extract_ISO8601_from_CF_Time + public :: extract_CF_Time_duration + public :: extract_CF_Time_unit + public :: convert_CF_Time_to_datetime_duration +! Convert ISO8601 datetime string to CF_Time_base_datetime + public :: convert_ISO8601_to_CF_Time_base_datetime + public :: CF_Time, CF_Time_Integer, CF_Time_Real + + public :: MAX_CHARACTER_LENGTH + +! PUBLIC PROCEDURES (INTERFACES): + +! Extract an ISO8601 datetime string from the base datetime string in a CF_Time. + interface extract_ISO8601_from_CF_Time + module procedure :: extract_ISO8601_from_CF_Time_units + module procedure :: extract_ISO8601_from_CF_Time_cf_time + end interface extract_ISO8601_from_CF_Time + +! Extract the duration of a CF Time. + interface extract_CF_Time_duration + module procedure :: extract_CF_Time_duration_cf_time_real + module procedure :: extract_CF_Time_duration_cf_time_integer + end interface extract_CF_Time_duration + +! Extract the time units from a CF Time. + interface extract_CF_Time_unit + module procedure :: extract_CF_Time_unit_cf_time + module procedure :: extract_CF_Time_unit_units + end interface extract_CF_Time_unit + +! Extract datetime_duration from CF Time. + interface convert_CF_Time_to_datetime_duration + module procedure :: convert_CF_Time_to_datetime_duration_integer + module procedure :: convert_CF_Time_to_datetime_duration_real + module procedure :: convert_CF_Time_to_datetime_duration_integer_duration + module procedure :: convert_CF_Time_to_datetime_duration_real_duration + end interface convert_CF_Time_to_datetime_duration + + +! PRIVATE INTERFACES: + + interface split + module procedure :: split_characters + end interface split + + +! TYPES (DEFINITIONS): + +! CF_TIME: derived type to hold the data for CF Time values + type, abstract :: CF_Time + logical :: is_valid + character(len=:), allocatable :: time_unit + character(len=:), allocatable :: base_datetime + end type CF_Time + + type, extends(CF_Time) :: CF_Time_Integer + integer :: duration + end type CF_Time_Integer + + type, extends(CF_Time) :: CF_Time_Real + real(kind=R64) :: duration + end type CF_Time_Real + + interface CF_Time_Integer + module procedure :: construct_cf_time_integer + end interface CF_Time_Integer + + interface CF_Time_Real + module procedure :: construct_cf_time_real + end interface CF_Time_Real + +! END CF_TIME + + +! CONSTANTS: + character, parameter :: DATE_DELIM = '-' + character, parameter :: TIME_DELIM = ':' + character, parameter :: ISO_DELIM = 'T' + character(len=2), parameter :: CF_DELIM = ' ' // ISO_DELIM + character(len=*), parameter :: EMPTY_STRING = '' + character, parameter :: DECIMAL_POINT = '.' + !character(len=*), parameter :: DIGIT_CHARACTERS = '1234567890' + +contains + + +! PUBLIC PROCEDURES (DEFINITION): + + subroutine extract_ISO8601_from_CF_Time_units(units, isostring, rc) + character(len=*), intent(in) :: units + character(len=MAX_CHARACTER_LENGTH), intent(out) :: isostring + integer, optional, intent(out) :: rc + integer :: status + + call extract_ISO8601_from_CF_Time(CF_Time_Integer(0, units), isostring, _RC) + + _RETURN(_SUCCESS) + + end subroutine extract_ISO8601_from_CF_Time_units + + subroutine extract_ISO8601_from_CF_Time_cf_time(cft, isostring, rc) + class(CF_Time), intent(in) :: cft + character(len=MAX_CHARACTER_LENGTH), intent(out) :: isostring + integer, optional, intent(out) :: rc + + if(cft % is_valid) then + isostring = convert_CF_Time_datetime_string_to_ISO8601(cft % base_datetime) + _RETURN(_SUCCESS) + end if + + _RETURN(_FAILURE) + + end subroutine extract_ISO8601_from_CF_Time_cf_time + + subroutine extract_CF_Time_duration_cf_time_real(cft, duration, rc) + class(CF_Time_Real), intent(in) :: cft + real(kind=R64), intent(out) :: duration + integer, optional, intent(out) :: rc + + if(cft % is_valid) then + duration = cft % duration + _RETURN(_SUCCESS) + end if + + _RETURN(_FAILURE) + + end subroutine extract_CF_Time_duration_cf_time_real + + subroutine extract_CF_Time_duration_cf_time_integer(cft, duration, rc) + class(CF_Time_Integer), intent(in) :: cft + integer, intent(out) :: duration + integer, optional, intent(out) :: rc + + if(cft % is_valid) then + duration = cft % duration + _RETURN(_SUCCESS) + end if + + _RETURN(_FAILURE) + + end subroutine extract_CF_Time_duration_cf_time_integer + + subroutine extract_CF_Time_unit_cf_time(cft, time_unit, rc) + class(CF_Time), intent(in) :: cft + character(len=MAX_CHARACTER_LENGTH), intent(out) :: time_unit + integer, optional, intent(out) :: rc + + if(cft % is_valid) then + time_unit = cft % time_unit + _RETURN(_SUCCESS) + end if + + _RETURN(_FAILURE) + + end subroutine extract_CF_Time_unit_cf_time + + subroutine extract_CF_Time_unit_units(units, time_unit, rc) + character(len=*), intent(in) :: units + character(len=MAX_CHARACTER_LENGTH), intent(out) :: time_unit + integer, optional, intent(out) :: rc + integer :: status + + call extract_CF_Time_unit(CF_Time_Integer(0, units), time_unit, _RC) + + _RETURN(_SUCCESS) + + end subroutine extract_CF_Time_unit_units + + subroutine convert_CF_Time_to_datetime_duration_integer(cft, dt_duration, rc) + class(CF_Time_Integer), intent(in) :: cft + type(datetime_duration), intent(out) :: dt_duration + integer, optional, intent(out) :: rc + integer(kind(TIME_UNIT)) :: tu + + if(.not. cft % is_valid) then + _RETURN(_FAILURE) + end if + + tu = get_time_unit(cft % time_unit) + _ASSERT(tu /= UNKNOWN_TIME_UNIT, 'Unable to find TIME_UNIT ' // cft % time_unit) + + call dt_duration % set_value(tu, cft % duration) + + _RETURN(_SUCCESS) + + end subroutine convert_CF_Time_to_datetime_duration_integer + + subroutine convert_CF_Time_to_datetime_duration_real(cft, dt_duration, rc) + class(CF_Time_Real), intent(in) :: cft + type(datetime_duration), intent(out) :: dt_duration + integer, optional, intent(out) :: rc + integer(kind(TIME_UNIT)) :: tu + + if(.not. cft % is_valid) then + _RETURN(_FAILURE) + end if + + tu = get_time_unit(cft % time_unit) + _ASSERT(tu /= UNKNOWN_TIME_UNIT, 'Unable to find TIME_UNIT ' // cft % time_unit) + + call dt_duration % set_value(tu, cft % duration) + + _RETURN(_SUCCESS) + + end subroutine convert_CF_Time_to_datetime_duration_real + + subroutine convert_CF_Time_to_datetime_duration_integer_duration(duration, units, dt_duration, rc) + integer, intent(in) :: duration + character(len=*), intent(in) :: units + type(datetime_duration), intent(out) :: dt_duration + integer, optional, intent(out) :: rc + integer :: status + + call convert_CF_Time_to_datetime_duration(CF_Time_Integer(duration, units), dt_duration, _RC) + + _RETURN(_SUCCESS) + + end subroutine convert_CF_Time_to_datetime_duration_integer_duration + + subroutine convert_CF_Time_to_datetime_duration_real_duration(duration, units, dt_duration, rc) + real(kind=R64), intent(in) :: duration + character(len=*), intent(in) :: units + type(datetime_duration), intent(out) :: dt_duration + integer, optional, intent(out) :: rc + integer :: status + + call convert_CF_Time_to_datetime_duration(CF_Time_Real(duration, units), dt_duration, _RC) + + _RETURN(_SUCCESS) + + end subroutine convert_CF_Time_to_datetime_duration_real_duration + + function convert_CF_Time_datetime_string_to_ISO8601(datetime_string) result(isodatetime) + character(len=*), intent(in) :: datetime_string + character(len=MAX_CHARACTER_LENGTH) :: isodatetime + character(len=MAX_CHARACTER_LENGTH) :: remainder + character(len=MAX_CHARACTER_LENGTH) :: part(NUM_TIME_UNITS) + + isodatetime = EMPTY_STRING + remainder = datetime_string + + call split(trim(remainder), part(YEAR_TIME_UNIT), remainder, DATE_DELIM) + call split(trim(remainder), part(MONTH_TIME_UNIT), remainder, DATE_DELIM) + call split(trim(remainder), part(DAY_TIME_UNIT), remainder, CF_DELIM) + call split(trim(remainder), part(HOUR_TIME_UNIT), remainder, TIME_DELIM) + call split(trim(remainder), part(MINUTE_TIME_UNIT), remainder, TIME_DELIM) + part(SECOND_TIME_UNIT) = trim(remainder) + + call update_datetime(isodatetime, part(YEAR_TIME_UNIT), 4, DATE_DELIM) + call update_datetime(isodatetime, part(MONTH_TIME_UNIT), 2, DATE_DELIM) + call update_datetime(isodatetime, part(DAY_TIME_UNIT), 2, ISO_DELIM) + call update_datetime(isodatetime, part(HOUR_TIME_UNIT), 2, TIME_DELIM) + call update_datetime(isodatetime, part(MINUTE_TIME_UNIT), 2, TIME_DELIM) + call update_datetime(isodatetime, part(SECOND_TIME_UNIT), 2) + + contains + + subroutine update_datetime(datetime_, text, width, delm) + character(len=MAX_CHARACTER_LENGTH), intent(inout) :: datetime_ + character(len=*), intent(in) :: text + integer, optional, intent(in) :: width + character(len=*), optional, intent(in) :: delm + character(len=MAX_CHARACTER_LENGTH) :: text_ + + text_ = text + if(present(width)) text_ = zero_pad(text, width) + datetime_ = trim(datetime_) // trim(text_) + if(present(delm)) datetime_ = trim(datetime_) // trim(delm) + + end subroutine update_datetime + + end function convert_CF_Time_datetime_string_to_ISO8601 + + function convert_ISO8601_to_CF_Time_base_datetime(isostring) result(base_datetime) + character(len=*), intent(in) :: isostring + character(len=len(isostring)) :: base_datetime + + base_datetime = remove_zero_pad(isostring) + base_datetime = substitute(base_datetime, 'T', ' ') + + end function convert_ISO8601_to_CF_Time_base_datetime + +! END PUBLIC PROCEDURES (DEFINITION) + + +! CONSTRUCTORS: + +! CF_TIME (CONSTRUCTORS): + + function construct_cf_time_integer(duration, units) result (cft) + integer, intent(in) :: duration + character(len=*), intent(in) :: units + type(CF_Time_Integer) :: cft + + cft % duration = duration + call initialize_cf_time(cft, units) + + end function construct_cf_time_integer + + function construct_cf_time_real(duration, units) result (cft) + real(kind=R64), intent(in) :: duration + character(len=*), intent(in) :: units + type(CF_Time_Real) :: cft + + cft % duration = duration + call initialize_cf_time(cft, units) + + end function construct_cf_time_real + + subroutine initialize_cf_time(cft, units) + class(CF_Time), intent(inout) :: cft + character(len=*), intent(in) :: units + character(len=MAX_CHARACTER_LENGTH) :: token, remainder + + cft % is_valid = .FALSE. + remainder = units + if(len_trim(remainder) == 0) return + call split(trim(remainder), token, remainder, CF_DELIM) + cft % time_unit = token + call split(trim(remainder), token, remainder, CF_DELIM) + cft % base_datetime = remainder + cft % is_valid = .TRUE. + + end subroutine initialize_cf_time + +! END CONSTRUCTORS + + +! UTILITY PROCEDURES: + +! ZERO_PAD - UTILITY + function zero_pad(number_string, width) result(padded) + character(len=*), intent(in) :: number_string + integer, intent(in) :: width + character(len=MAX_CHARACTER_LENGTH) :: padded + integer :: num_zeros + + num_zeros = width - len_trim(number_string) + if(num_zeros > 0) then + padded = repeat('0', num_zeros) // number_string + else + padded = number_string + end if + + end function zero_pad + +! SPLITTER - UTILITY + subroutine split_characters(characters, token, remainder, delimiters) + character(len=*), intent(in) :: characters + character(len=MAX_CHARACTER_LENGTH), intent(out) :: token + character(len=MAX_CHARACTER_LENGTH), intent(out) :: remainder + character(len=*), optional, intent(in) :: delimiters + character(len=:), allocatable :: delims + integer :: i + + delims = ' ' + if(present(delimiters)) delims = delimiters + + i = scan(characters, delims) + + if(i > 0) then + token = characters(:(i-1)) + remainder = characters((i+1):) + else + token = characters + remainder = EMPTY_STRING + endif + + end subroutine split_characters + +! UTILITIES + + function remove_zero_pad(isostring) result(unpadded) + character(len=*), intent(in) :: isostring + character(len=len(isostring)) :: unpadded + character(len=:), allocatable :: part(:) + character(len=len(isostring)) :: fraction_part + integer :: i + + part = get_ISO8601_substrings(isostring) + fraction_part = get_ISO8601_fractional_seconds(isostring) + unpadded = trim(part(1)) + do i = 2, size(part) + part(i) = strip_zero(part(i)) + unpadded = trim(unpadded) // trim(part(i)) + end do + + fraction_part = strip_zero(fraction_part, back = .TRUE.) + if(len_trim(fraction_part) > 0) unpadded = trim(unpadded) // DECIMAL_POINT // trim(fraction_part) + + end function remove_zero_pad + + function substitute(string, ch1, ch2) result(replaced) + character(len=*), intent(in) :: string + character, intent(in) :: ch1, ch2 + character(len=len(string)) :: replaced + integer :: i, j + + j = 0 + replaced = string + i = index(replaced((j+1):), ch1) + do while (i > 0) + j = j + i + if(j > len(replaced)) exit + replaced(j:j) = ch2 + if(j == len(replaced)) exit + i = index(replaced((j+1):), ch1) + end do + + end function substitute + + elemental logical function is_zero(ch) + character, intent(in) :: ch + is_zero = (ch == '0') + end function is_zero + + function get_ISO8601_substrings(isostring) result(substring) + character(len=*), intent(in) :: isostring + integer, parameter :: NUM_DT_PARTS = 6 + integer, parameter :: DT_PART_WIDTH = 5 + character(len=DT_PART_WIDTH) :: substring(NUM_DT_PARTS) + + substring = EMPTY_STRING + + substring(1) = isostring(1:5) + substring(2) = isostring(6:8) + substring(3) = isostring(9:11) + substring(4) = isostring(12:14) + substring(5) = isostring(15:17) + substring(6) = isostring(18:19) + + end function get_ISO8601_substrings + + function get_ISO8601_fractional_seconds(isostring) result(fs) + character(len=*), intent(in) :: isostring + integer, parameter :: FIRST_INDEX = 20 + character(len=len(isostring)) :: fs + integer :: i, j + + fs = EMPTY_STRING + if(len_trim(isostring) < FIRST_INDEX) return + i = FIRST_INDEX + if(isostring(i:i) /= DECIMAL_POINT) return + i = i + 1 + j = verify(isostring(i:), DIGIT_CHARACTERS) + select case(j) + case(0) + fs = isostring(i:) + case(1) + return + case default + j = j + i - 2 + fs = isostring(i:j) + end select + + end function get_ISO8601_fractional_seconds + + function strip_zero(string, back) result(stripped) + character(len=*), intent(in) :: string + logical, optional, intent(in) :: back + character(len=len(string)) :: stripped + logical :: back_ + integer :: i, j, n + character :: ch + + stripped = EMPTY_STRING + back_ = .FALSE. + if(present(back)) back_ = back + + n = len_trim(string) + if(back_) then + i = 1 + do j = n, i, -1 + ch = string(j:j) + if(.not. is_zero(ch)) exit + end do + else + j = n + do i = 1, n + ch = string(i:i) + if(.not. is_zero(ch)) exit + end do + i = min(i, j) + end if + + stripped = string(i:j) + + end function strip_zero + +end module MAPL_CF_Time diff --git a/shared/MAPL_DateTime_Parsing.F90 b/shared/MAPL_DateTime_Parsing.F90 index 7c26fc227ceb..e16672061745 100644 --- a/shared/MAPL_DateTime_Parsing.F90 +++ b/shared/MAPL_DateTime_Parsing.F90 @@ -28,29 +28,45 @@ ! hh?mm or Thhmm ! hh ! hh is the zero-padded hour (24 hour system). -! mm is the zero-padded minute. +! mm is the zero-padded minute. ! ss is the zero-padded second. ! sss is the fractional second. It represents an arbitrary number of digits (currrently limited to 3). ! ! Fully-formed time with time zone. Local time not-supported !