fixes #1941

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

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,29 +5444,34 @@ 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)
        call ESMF_FieldGet(field, rank=fieldRank,rc=status)
        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')

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

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 (

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 

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 $<BUILD_INTERFACE:${MAPL_SOURCE_DIR}/include>)
 
+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)

pfio/DownBit.F90 → 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

shared/MaplShared.F90

@@ -20,5 +20,6 @@ module MaplShared
    use mapl_Constants
    use mapl_CommGroupDescriptionMod
    use mapl_AbstractCommSplitterMod
+   use mapl_DownbitMod
 
 end module MaplShared