From 36af93e95d1212fbfd5b6ffabe43a3bf5c9e8bff Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 1 Feb 2023 15:27:06 -0500 Subject: [PATCH] fixes #1941 --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 13 ++- griddedio/GriddedIO.F90 | 13 ++- pfio/CMakeLists.txt | 5 +- pfio/pFIO.F90 | 1 - shared/CMakeLists.txt | 4 + {pfio => shared}/DownBit.F90 | 89 ++++++++++++++----- shared/MaplShared.F90 | 1 + .../ShaveMantissa.c | 43 ++++----- .../ShaveMantissa.h | 4 +- 10 files changed, 120 insertions(+), 54 deletions(-) rename {pfio => shared}/DownBit.F90 (69%) rename pfio/pFIO_ShaveMantissa.c => shared/ShaveMantissa.c (79%) rename pfio/pFIO_ShaveMantissa.h => shared/ShaveMantissa.h (73%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..6cee76a40c9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes - Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a convenient local solar hour angle diagnostic which will be used to detect local solar noon via the `EXAMPLE OF USE` in the subroutine header. See `DESCRIPTION` in code diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index b5a5e179ba4..522ec9a1473 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -39,7 +39,7 @@ module MAPL_HistoryGridCompMod use MAPL_GriddedIOitemVectorMod use MAPL_GriddedIOitemMod use pFIO_ClientManagerMod, only: o_Clients - use pFIO_DownbitMod, only: pFIO_DownBit + use MAPL_DownbitMod use pFIO_ConstantsMod use HistoryTrajectoryMod use MAPL_StringTemplate @@ -5444,11 +5444,16 @@ subroutine shavebits( state, list, rc) integer :: m, fieldRank, status type(ESMF_Field) :: field real, pointer :: ptr1d(:), ptr2d(:,:), ptr3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm if (list%nbits_to_keep >=MAPL_NBITS_UPPER_LIMIT) then _RETURN(ESMF_SUCCESS) endif + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) + do m=1,list%field_set%nfields call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,rc=status ) _VERIFY(STATUS) @@ -5456,17 +5461,17 @@ subroutine shavebits( state, list, rc) if (fieldRank ==1) then call ESMF_FieldGet(field, farrayptr=ptr1d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) elseif (fieldRank ==2) then call ESMF_FieldGet(field, farrayptr=ptr2d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) elseif (fieldRank ==3) then call ESMF_FieldGet(field, farrayptr=ptr3d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) else _FAIL('The field rank is not implmented') diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index a875388e015..cea3383893f 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -22,6 +22,7 @@ module MAPL_GriddedIOMod use gFTL_StringVector use gFTL_StringStringMap use MAPL_FileMetadataUtilsMod + use MAPL_DownbitMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL64 use ieee_arithmetic, only: isnan => ieee_is_nan @@ -872,6 +873,12 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) integer, allocatable :: localStart(:),globalStart(:),globalCount(:) integer, allocatable :: gridLocalStart(:),gridGlobalStart(:),gridGlobalCount(:) class (AbstractGridFactory), pointer :: factory + real, allocatable :: temp_2d(:,:), temp_3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) factory => get_factory(this%output_grid,rc=status) _VERIFY(status) @@ -888,7 +895,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(Field,farrayPtr=ptr2d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_2d,source=ptr2d) + call DownBit(temp_2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else @@ -903,7 +911,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_3d,source=ptr3d) + call DownBit(temp_3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 1557e979e0b..840662c1252 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -10,8 +10,6 @@ endif() set (srcs # pFIO Files - pFIO_ShaveMantissa.c - DownBit.F90 pFIO_Constants.F90 UnlimitedEntity.F90 Attribute.F90 @@ -132,7 +130,8 @@ endforeach() ecbuild_add_executable ( TARGET pfio_open_close.x SOURCES pfio_open_close.F90 - LIBS ${this} ) + LIBS ${this}) + set_target_properties (pfio_open_close.x PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) ecbuild_add_executable ( diff --git a/pfio/pFIO.F90 b/pfio/pFIO.F90 index 9f3c96d15b2..395a60a339b 100644 --- a/pfio/pFIO.F90 +++ b/pfio/pFIO.F90 @@ -28,7 +28,6 @@ module pFIO use pFIO_ArrayReferenceMod use pFIO_StringAttributeMapMod use pFIO_StringVariableMapMod - use pFIO_DownBitMod use pFIO_LocalMemReferenceMod use pFIO_FormatterPtrVectorMod use pFIO_StringVectorUtilMod diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index dfb33d1d6eb..e61ae7a52b3 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -25,6 +25,8 @@ set (srcs FileSystemUtilities.F90 DSO_Utilities.F90 MAPL_ISO8601_DateTime.F90 + DownBit.F90 + ShaveMantissa.c # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 @@ -39,6 +41,8 @@ endif () target_include_directories (${this} PUBLIC $) +set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) + target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") if (PFUNIT_FOUND) diff --git a/pfio/DownBit.F90 b/shared/DownBit.F90 similarity index 69% rename from pfio/DownBit.F90 rename to shared/DownBit.F90 index 96760f9a852..579e62d7c9e 100644 --- a/pfio/DownBit.F90 +++ b/shared/DownBit.F90 @@ -1,20 +1,23 @@ -module pFIO_DownbitMod +#include "MAPL_Generic.h" +module MAPL_DownbitMod use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc, c_ptr + use mpi + use MAPL_ExceptionHandling implicit none private - public :: pFIO_DownBit + public :: DownBit - interface pFIO_DownBit - module procedure pFIO_DownBit1D - module procedure pFIO_DownBit2D - module procedure pFIO_DownBit3D - end interface pFIO_DownBit + interface DownBit + module procedure DownBit1D + module procedure DownBit2D + module procedure DownBit3D + end interface DownBit contains - subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit3D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -27,6 +30,7 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -55,13 +59,13 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) integer :: k do k = lbound(x,3), ubound(x,3) - call pFIO_DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & - undef=undef, flops=flops, rc=rc ) + call DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & + undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc ) end do - end subroutine pFIO_DownBit3D + end subroutine DownBit3D - subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit2D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -73,6 +77,7 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -114,13 +119,20 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) ! !EOP !------------------------------------------------------------------------------ - integer :: E, xbits, has_undef + integer :: E, xbits, has_undef, passed_minmax real :: scale, xmin, xmax, tol, undef_ logical :: shave_mantissa - integer, external :: pFIO_ShaveMantissa32 + integer, external :: MAPL_ShaveMantissa32 + real :: min_value, max_value + integer :: useable_mpi_comm,status rc = 0 + if (present(mpi_comm)) then + useable_mpi_comm = mpi_comm + else + useable_mpi_comm = MPI_COMM_NULL + end if ! Defaults for optinal arguments ! ------------------------------ if ( present(undef) ) then @@ -143,7 +155,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) xr = x ! compiled r8 this will convert to r4. xbits = 24 - nbits_to_keep - rc = pFIO_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x) ) + call compute_min_max(xr,min_value,max_value,undef_,useable_mpi_comm,_RC) + if (useable_mpi_comm/=MPI_COMM_NULL) passed_minmax = 1 + rc = MAPL_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x), passed_minmax, min_value, max_value ) return ! Slow, flops in FORTRAN (GRIB inspired) @@ -180,9 +194,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) end if - end subroutine pFIO_DownBit2D + end subroutine DownBit2D - subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit1D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE ! ! !INPUT PARAMETERS: @@ -192,6 +206,7 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -208,8 +223,38 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) xr_ptr = c_loc(xr(1)) call c_f_pointer(xr_ptr, xr_tmp,[size(x),1]) - call pFIO_Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, rc=rc) - - end subroutine pFIO_Downbit1D - -end module pFIO_DownbitMod + call Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc) + + end subroutine Downbit1D + + subroutine compute_min_max(array,min_value,max_value,undef_value,mpi_comm,rc) + real, intent(in) :: array(:,:) + real, intent(out) :: min_value + real, intent(out) :: max_value + real, intent(in ) :: undef_value + integer, intent(in ) :: mpi_comm + integer, optional, intent(out) :: rc + + real :: local_min_value, local_max_value + logical, allocatable :: undef_mask(:,:) + integer :: status + + allocate(undef_mask(size(array,1),size(array,2))) + undef_mask = .false. + where(array /= undef_value) undef_mask = .true. + + local_min_value = minval(array,mask=undef_mask) + local_max_value = maxval(array,mask=undef_mask) + if (mpi_comm /= MPI_COMM_NULL) then + call MPI_AllReduce(local_min_value,min_value,1,MPI_FLOAT,MPI_MIN,mpi_comm,status) + _VERIFY(status) + call MPI_AllReduce(local_max_value,max_value,1,MPI_FLOAT,MPI_MAX,mpi_comm,status) + _VERIFY(status) + else + min_value = local_min_value + max_value = local_max_value + end if + _RETURN(_SUCCESS) + end subroutine + +end module MAPL_DownbitMod diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index b48e69f3b0d..404e987803a 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -20,5 +20,6 @@ module MaplShared use mapl_Constants use mapl_CommGroupDescriptionMod use mapl_AbstractCommSplitterMod + use mapl_DownbitMod end module MaplShared diff --git a/pfio/pFIO_ShaveMantissa.c b/shared/ShaveMantissa.c similarity index 79% rename from pfio/pFIO_ShaveMantissa.c rename to shared/ShaveMantissa.c index 145fb9617f1..5d84136d73a 100644 --- a/pfio/pFIO_ShaveMantissa.c +++ b/shared/ShaveMantissa.c @@ -2,7 +2,7 @@ #include #include #include -#include "pFIO_ShaveMantissa.h" /* protype */ +#include "ShaveMantissa.h" /* protype */ #define MAXBITS 20 @@ -22,7 +22,7 @@ //======================================== -float32 pfio_SetOffset(float32 minv, float32 maxv) +float32 MAPL_SetOffset(float32 minv, float32 maxv) { float32 midv, mnabs, range; @@ -43,7 +43,7 @@ float32 pfio_SetOffset(float32 minv, float32 maxv) // // !INTERFACE: */ -int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize ) +int MAPL_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize, int passed_minmax, float32 arr_min, float32 arr_max ) /* // !INPUT PARAMETERS: @@ -101,7 +101,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int // was not copying input to output arrays. // 10Mar2009 Suarez Used a union for the shaving. Also changed the // SKIP checks and protected the max and min. -// 24oct2009 da Silva Changed abs() to fabs() in pfio_SetOffset; moved float32 +// 24oct2009 da Silva Changed abs() to fabs() in MAPL_SetOffset; moved float32 // defs to header so that it can be used with prototype. // 28oct2010 da Silva Changed another occurence of abs() -> fabs() //EOP @@ -125,14 +125,14 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int if ( len < 0 || xbits < 1 ) { fprintf(stderr, - "ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", + "MAPL_ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", len, xbits ); return 1; } if ( xbits > MAXBITS ) { fprintf(stderr, - "ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", + "MAPL_ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", xbits, MAXBITS ); return 2; } @@ -155,7 +155,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int b = a; if(ain!=a) { if(labs(ain-a)