Added routines to broadcast/scatter 1D integer or character arrays. (a2f39ed4) · Commits · CAMS / CSO

oper/src/cso_comm.F90

+168 −24

Original line number	Diff line number	Diff line
		@@ -13,7 +13,7 @@
		! https://computing.llnl.gov/tutorials/mpi/
		!
		!
		! HISTORY
		! CHANGES
		!
		! 2023-01, Arjo Segers
		! Support integer(1) and character variables.
		@@ -21,6 +21,9 @@
		! 2025-02, Arjo Segers
		! Removed comment from 'use MPI' statements after compiler complained.
		!
		! 2026-07, Arjo Segers
		! Added routine to broadcast 1D character arrays.
		!
		!### macro's ###########################################################
		!
		#define TRACEBACK write (csol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call csoErr
		@@ -145,6 +148,7 @@ module CSO_Comm
		procedure :: CSO_Comm_BCast_r8_3d
		procedure :: CSO_Comm_BCast_r8_4d
		procedure :: CSO_Comm_BCast_c
		procedure :: CSO_Comm_BCast_c_1d
		generic :: BCast => CSO_Comm_BCast_i, &
		CSO_Comm_BCast_i1_1d, &
		CSO_Comm_BCast_i_1d, &
		@@ -158,7 +162,8 @@ module CSO_Comm
		CSO_Comm_BCast_r8_2d, &
		CSO_Comm_BCast_r8_3d, &
		CSO_Comm_BCast_r8_4d, &
		CSO_Comm_BCast_c
		CSO_Comm_BCast_c, &
		CSO_Comm_BCast_c_1d
		!
		procedure :: CSO_Comm_Gather_i
		procedure :: CSO_Comm_Gather_i_1d
		@@ -175,8 +180,8 @@ module CSO_Comm
		CSO_Comm_AllGather_r1
		!
		procedure CSO_Comm_GatherV_i1_1d
		procedure CSO_Comm_GatherV_i_1d
		procedure CSO_Comm_GatherV_i_2d
		procedure CSO_Comm_GatherV_i4_1d
		procedure CSO_Comm_GatherV_i4_2d
		procedure CSO_Comm_GatherV_r4_1d
		procedure CSO_Comm_GatherV_r8_1d
		procedure CSO_Comm_GatherV_c1_2d
		@@ -185,8 +190,8 @@ module CSO_Comm
		procedure CSO_Comm_GatherV_r4_3d
		procedure CSO_Comm_GatherV_r8_3d
		generic :: GatherV => CSO_Comm_GatherV_i1_1d, &
		CSO_Comm_GatherV_i_1d, &
		CSO_Comm_GatherV_i_2d, &
		CSO_Comm_GatherV_i4_1d, &
		CSO_Comm_GatherV_i4_2d, &
		CSO_Comm_GatherV_r4_1d, &
		CSO_Comm_GatherV_r8_1d, &
		CSO_Comm_GatherV_c1_2d, &
		@@ -201,6 +206,7 @@ module CSO_Comm
		CSO_Comm_Gather2D_r8
		!
		procedure CSO_Comm_ScatterV_i1_1d
		procedure CSO_Comm_ScatterV_i4_1d
		procedure CSO_Comm_ScatterV_r4_1d
		procedure CSO_Comm_ScatterV_c1_2d
		procedure CSO_Comm_ScatterV_r4_2d
		@@ -209,6 +215,7 @@ module CSO_Comm
		procedure CSO_Comm_ScatterV_r8_2d
		procedure CSO_Comm_ScatterV_r8_3d
		generic :: ScatterV => CSO_Comm_ScatterV_i1_1d, &
		CSO_Comm_ScatterV_i4_1d, &
		CSO_Comm_ScatterV_r4_1d, &
		CSO_Comm_ScatterV_c1_2d, &
		CSO_Comm_ScatterV_r4_2d, &
		@@ -2287,6 +2294,50 @@ contains
		end subroutine CSO_Comm_BCast_c


		! *


		subroutine CSO_Comm_BCast_c_1d( self, rootid, values, status )

		#ifdef _MPI
		use MPI_F08, only : MPI_DataType
		use MPI_F08, only : MPI_BCast
		#endif

		! --- in/out ---------------------------------

		class(T_CSO_Comm), intent(in) :: self
		integer, intent(in) :: rootid
		character(len=*), intent(inout) :: values(:)
		integer, intent(out) :: status

		! --- const ----------------------------------

		character(len=*), parameter :: rname = mname//'/CSO_Comm_BCast_c_1d'

		! --- local ----------------------------------

		#ifdef _MPI
		type(MPI_DataType) :: dtype
		#endif

		! --- begin ----------------------------------

		#ifdef _MPI
		! data type:
		call self%GetDataType( 'char', 1, dtype, status )
		IF_NOT_OK_RETURN(status=1)
		! send values from root to all other pe's:
		call MPI_BCast( values, len(values(1))*size(values), dtype, rootid, self%comm, ierror=status )
		IF_MPI_NOT_OK_RETURN(status=1)
		#endif

		! ok
		status = 0

		end subroutine CSO_Comm_BCast_c_1d


		! ********************************************************************
		! ***
		! *** gather
		@@ -2717,7 +2768,7 @@ contains

		! *

		subroutine CSO_Comm_GatherV_i_1d( self, send, recv, status, &
		subroutine CSO_Comm_GatherV_i4_1d( self, send, recv, status, &
		nloc )

		#ifdef _MPI
		@@ -2728,15 +2779,15 @@ contains
		! --- in/out ---------------------------------

		class(T_CSO_Comm), intent(in) :: self
		integer, intent(in) :: send(:) ! (max(1,nloc))
		integer, intent(out) :: recv(:) ! (sum nloc)
		integer(4), intent(in) :: send(:) ! (max(1,nloc))
		integer(4), intent(out) :: recv(:) ! (sum nloc)
		integer, intent(out) :: status

		integer, intent(in), optional :: nloc

		! --- const ----------------------------------

		character(len=*), parameter :: rname = mname//'/CSO_Comm_GatherV_i_1d'
		character(len=*), parameter :: rname = mname//'/CSO_Comm_GatherV_i4_1d'

		! --- local ----------------------------------

		@@ -2744,8 +2795,8 @@ contains
		integer :: ntot
		#ifdef _MPI
		type(MPI_DataType) :: dtype
		integer, allocatable :: recvcounts(:) ! (npes)
		integer, allocatable :: displs(:) ! (npes)
		integer(4), allocatable :: recvcounts(:) ! (npes)
		integer(4), allocatable :: displs(:) ! (npes)
		#endif

		! --- begin ----------------------------------
		@@ -2803,11 +2854,11 @@ contains
		! ok
		status = 0

		end subroutine CSO_Comm_GatherV_i_1d
		end subroutine CSO_Comm_GatherV_i4_1d

		! *

		subroutine CSO_Comm_GatherV_i_2d( self, send, recv, status, &
		subroutine CSO_Comm_GatherV_i4_2d( self, send, recv, status, &
		nloc )

		#ifdef _MPI
		@@ -2818,15 +2869,15 @@ contains
		! --- in/out ---------------------------------

		class(T_CSO_Comm), intent(in) :: self
		integer, intent(in) :: send(:,:) ! (m,max(1,nloc))
		integer, intent(out) :: recv(:,:) ! (m,sum nloc)
		integer(4), intent(in) :: send(:,:) ! (m,max(1,nloc))
		integer(4), intent(out) :: recv(:,:) ! (m,sum nloc)
		integer, intent(out) :: status

		integer, intent(in), optional :: nloc

		! --- const ----------------------------------

		character(len=*), parameter :: rname = mname//'/CSO_Comm_GatherV_i_2d'
		character(len=*), parameter :: rname = mname//'/CSO_Comm_GatherV_i4_2d'

		! --- local ----------------------------------

		@@ -2835,8 +2886,8 @@ contains
		#ifdef _MPI
		integer :: ntot
		type(MPI_DataType) :: dtype
		integer, allocatable :: recvcounts(:) ! (npes)
		integer, allocatable :: displs(:) ! (npes)
		integer(4), allocatable :: recvcounts(:) ! (npes)
		integer(4), allocatable :: displs(:) ! (npes)
		#endif

		! --- begin ----------------------------------
		@@ -2899,7 +2950,7 @@ contains
		! ok
		status = 0

		end subroutine CSO_Comm_GatherV_i_2d
		end subroutine CSO_Comm_GatherV_i4_2d

		! *

		@@ -3944,6 +3995,99 @@ contains

		! *


		subroutine CSO_Comm_ScatterV_i4_1d( self, send, recv, status, &
		nloc )

		#ifdef _MPI
		use MPI_F08, only : MPI_DataType
		use MPI_F08, only : MPI_ScatterV
		#endif

		! --- in/out ---------------------------------

		integer, parameter :: wp = 4

		class(T_CSO_Comm), intent(in) :: self
		integer(wp), intent(in) :: send(:) ! (sum nloc)
		integer(wp), intent(out) :: recv(:) ! (max(1,nloc))
		integer, intent(out) :: status

		integer, intent(in), optional :: nloc

		! --- const ----------------------------------

		character(len=*), parameter :: rname = mname//'/CSO_Comm_ScatterV_i4_1d'

		! --- local ----------------------------------

		integer :: n
		#ifdef _MPI
		type(MPI_DataType) :: dtype
		integer :: ntot
		integer, allocatable :: sendcounts(:) ! (npes)
		integer, allocatable :: displs(:) ! (npes)
		#endif

		! --- begin ----------------------------------

		! local size, take from optional argument if present (value is probably zero ..)
		if ( present(nloc) ) then
		n = nloc
		else
		n = size(recv)
		end if

		#ifdef _MPI

		! data type:
		call self%GetDataType( 'integer', wp, dtype, status )
		IF_NOT_OK_RETURN(status=1)

		! storage:
		allocate( sendcounts(0:self%npes-1), stat=status )
		IF_NOT_OK_RETURN(status=1)
		allocate( displs(0:self%npes-1), stat=status )
		IF_NOT_OK_RETURN(status=1)

		! collect numbers:
		call self%ParInfo( n, status, ntot=ntot, sendcounts=sendcounts, displs=displs )
		IF_NOT_OK_RETURN(status=1)

		! check ...
		if ( self%root ) then
		if ( size(send) /= ntot ) then
		write (csol,'("send buffer has size ",i0," while ntot is ",i0)') size(send), ntot; call csoErr
		TRACEBACK; status=1; return
		end if
		end if

		! collect values from all pe's on root:
		call MPI_ScatterV( send, sendcounts, displs, dtype, &
		recv, n , dtype, &
		self%root_id, self%comm, ierror=status )
		IF_MPI_NOT_OK_RETURN(status=1)

		! clear:
		deallocate( sendcounts, stat=status )
		IF_NOT_OK_RETURN(status=1)
		deallocate( displs, stat=status )
		IF_NOT_OK_RETURN(status=1)

		#else

		! just copy ...
		if ( n > 0 ) recv(1:n) = send(1:n)

		#endif

		! ok
		status = 0

		end subroutine CSO_Comm_ScatterV_i4_1d

		! *

		subroutine CSO_Comm_ScatterV_r4_1d( self, send, recv, status, &
		nloc )