Skip to content

Commit b54a662

Browse files
adit4443yaadit4443ya
authored
Feat: Add Wrappers for MPI_AllGatherv (#124)
* Add Test for AllGatherv * Add wrappers for MPI_AllGatherv
1 parent ee6ec9b commit b54a662

File tree

3 files changed

+161
-0
lines changed

3 files changed

+161
-0
lines changed

‎src/mpi.f90‎

Lines changed: 88 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -96,6 +96,11 @@ module mpi
9696
module procedure MPI_Waitall_proc
9797
end interface
9898

99+
interface MPI_Allgatherv
100+
module procedure MPI_Allgatherv_int
101+
module procedure MPI_Allgatherv_real
102+
end interface MPI_Allgatherv
103+
99104
interface MPI_Ssend
100105
module procedure MPI_Ssend_proc
101106
end interface
@@ -799,6 +804,89 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror)
799804

800805
end subroutine MPI_Waitall_proc
801806

807+
subroutine MPI_Allgatherv_int(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
808+
displs, recvtype, comm, ierror)
809+
use iso_c_binding, only: c_int, c_ptr, c_loc
810+
use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
811+
integer, dimension(:), intent(in), target :: sendbuf
812+
integer, intent(in) :: sendcount
813+
integer, intent(in) :: sendtype
814+
integer, dimension(:), intent(out), target :: recvbuf
815+
integer, dimension(:), intent(in) :: recvcounts
816+
integer, dimension(:), intent(in) :: displs
817+
integer, intent(in) :: recvtype
818+
integer, intent(in) :: comm
819+
integer, optional, intent(out) :: ierror
820+
integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
821+
type(c_ptr) :: c_sendbuf, c_recvbuf
822+
integer(c_int) :: local_ierr
823+
824+
! Handle sendbuf (support MPI_IN_PLACE)
825+
if (sendbuf(1) == MPI_IN_PLACE) then
826+
c_sendbuf = c_MPI_IN_PLACE
827+
else
828+
c_sendbuf = c_loc(sendbuf)
829+
end if
830+
c_recvbuf = c_loc(recvbuf)
831+
c_sendtype = handle_mpi_datatype_f2c(sendtype)
832+
c_recvtype = handle_mpi_datatype_f2c(recvtype)
833+
c_comm = handle_mpi_comm_f2c(comm)
834+
835+
! Call C MPI_Allgatherv
836+
local_ierr = c_mpi_allgatherv(c_sendbuf, sendcount, c_sendtype, &
837+
c_recvbuf, recvcounts, displs, c_recvtype, &
838+
c_comm)
839+
840+
! Handle error
841+
if (present(ierror)) then
842+
ierror = local_ierr
843+
else if (local_ierr /= MPI_SUCCESS) then
844+
print *, "MPI_Allgatherv failed with error code: ", local_ierr
845+
end if
846+
847+
end subroutine MPI_Allgatherv_int
848+
849+
subroutine MPI_Allgatherv_real(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
850+
displs, recvtype, comm, ierror)
851+
use iso_c_binding, only: c_int, c_ptr, c_loc
852+
use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
853+
real(8), dimension(:), intent(in), target :: sendbuf
854+
integer, intent(in) :: sendcount
855+
integer, intent(in) :: sendtype
856+
real(8), dimension(:), intent(out), target :: recvbuf
857+
integer, dimension(:), intent(in) :: recvcounts
858+
integer, dimension(:), intent(in) :: displs
859+
integer, intent(in) :: recvtype
860+
integer, intent(in) :: comm
861+
integer, optional, intent(out) :: ierror
862+
integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
863+
type(c_ptr) :: c_sendbuf, c_recvbuf
864+
integer(c_int) :: local_ierr
865+
866+
if (sendbuf(1) == MPI_IN_PLACE) then
867+
c_sendbuf = c_MPI_IN_PLACE
868+
else
869+
c_sendbuf = c_loc(sendbuf)
870+
end if
871+
872+
c_recvbuf = c_loc(recvbuf)
873+
c_sendtype = handle_mpi_datatype_f2c(sendtype)
874+
c_recvtype = handle_mpi_datatype_f2c(recvtype)
875+
c_comm = handle_mpi_comm_f2c(comm)
876+
877+
! Call C MPI_Allgatherv
878+
local_ierr = c_mpi_allgatherv(c_sendbuf, sendcount, c_sendtype, &
879+
c_recvbuf, recvcounts, displs, c_recvtype, &
880+
c_comm)
881+
882+
if (present(ierror)) then
883+
ierror = local_ierr
884+
else if (local_ierr /= MPI_SUCCESS) then
885+
print *, "MPI_Allgatherv failed with error code: ", local_ierr
886+
end if
887+
888+
end subroutine MPI_Allgatherv_real
889+
802890
subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror)
803891
use iso_c_binding, only: c_int, c_ptr
804892
use mpi_c_bindings, only: c_mpi_ssend

‎src/mpi_c_bindings.f90‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -228,6 +228,20 @@ function c_mpi_cart_create(comm_old, ndims, dims, periods, reorder, comm_cart) b
228228
integer(c_int) :: c_mpi_cart_create
229229
end function
230230

231+
function c_mpi_allgatherv(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
232+
displs, recvtype, comm) bind(C, name="MPI_Allgatherv")
233+
use iso_c_binding, only: c_int, c_ptr
234+
type(c_ptr), value :: sendbuf
235+
integer(c_int), value :: sendcount
236+
integer(kind=MPI_HANDLE_KIND), value :: sendtype
237+
type(c_ptr), value :: recvbuf
238+
integer(c_int), dimension(*) :: recvcounts
239+
integer(c_int), dimension(*) :: displs
240+
integer(kind=MPI_HANDLE_KIND), value :: recvtype
241+
integer(kind=MPI_HANDLE_KIND), value :: comm
242+
integer(c_int) :: c_mpi_allgatherv
243+
end function c_mpi_allgatherv
244+
231245
function c_mpi_cart_coords(comm, rank, maxdims, coords) bind(C, name="MPI_Cart_coords")
232246
use iso_c_binding, only: c_int, c_ptr
233247
integer(kind=MPI_HANDLE_KIND), value :: comm

‎tests/allgatherv_1.f90‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
program allgatherv_1
2+
use mpi
3+
implicit none
4+
integer :: ierr, rank, size
5+
integer, allocatable :: sendbuf(:), recvbuf(:)
6+
integer, allocatable :: recvcounts(:), displs(:)
7+
integer :: sendcount, i, total
8+
logical :: error
9+
10+
! Initialize MPI
11+
call MPI_Init(ierr)
12+
call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
13+
call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
14+
15+
! Each process sends 'rank + 1' integers
16+
sendcount = rank + 1
17+
allocate(sendbuf(sendcount))
18+
do i = 1, sendcount
19+
sendbuf(i) = rank * 100 + i ! Unique values per process
20+
end do
21+
22+
! All processes allocate receive buffers
23+
allocate(recvcounts(size))
24+
allocate(displs(size))
25+
total = 0
26+
do i = 1, size
27+
recvcounts(i) = i ! Process i-1 sends i elements
28+
displs(i) = total ! Displacement in recvbuf
29+
total = total + recvcounts(i)
30+
end do
31+
allocate(recvbuf(total))
32+
recvbuf = 0
33+
34+
! Perform allgather
35+
call MPI_Allgatherv(sendbuf, sendcount, MPI_INTEGER, recvbuf, recvcounts, &
36+
displs, MPI_INTEGER, MPI_COMM_WORLD, ierr)
37+
38+
! Verify results on all processes
39+
error = .false.
40+
do i = 1, size
41+
do sendcount = 1, i
42+
if (recvbuf(displs(i) + sendcount) /= (i-1)*100 + sendcount) then
43+
print *, "Rank ", rank, ": Error at source rank ", i-1, &
44+
" index ", sendcount, ": expected ", (i-1)*100 + sendcount, &
45+
", got ", recvbuf(displs(i) + sendcount)
46+
error = .true.
47+
end if
48+
end do
49+
end do
50+
if (.not. error) then
51+
print *, "MPI_Allgatherv test passed on rank ", rank
52+
end if
53+
54+
! Clean up
55+
deallocate(sendbuf, recvbuf, recvcounts, displs)
56+
call MPI_Finalize(ierr)
57+
58+
if (error) stop 1
59+
end program allgatherv_1

0 commit comments

Comments
 (0)