Repository: lfortran/fortran_mpi
Pull request #124: Feat: Add Wrappers for MPI_AllGatherv
Author: login: adit4443ya
Labels: name: enhancement
description: New feature or request
Created: 2025-05-20T06:01:47Z | Merged: 2025-05-21T06:12:45Z

Towards #121 

MPI_Allgatherv is similar to MPI_Gatherv, but instead of gathering data to a single root process, it gathers data to all processes in the communicator.


Diff:
diff --git a/src/mpi.f90 b/src/mpi.f90
index a48ba26..21af0d3 100644
--- a/src/mpi.f90
+++ b/src/mpi.f90
@@ -92,6 +92,11 @@ module mpi
         module procedure MPI_Waitall_proc
     end interface
 
+    interface MPI_Allgatherv
+        module procedure MPI_Allgatherv_int
+        module procedure MPI_Allgatherv_real
+    end interface MPI_Allgatherv
+
     interface MPI_Ssend
         module procedure MPI_Ssend_proc
     end interface
@@ -773,6 +778,89 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror)
 
     end subroutine MPI_Waitall_proc
 
+    subroutine MPI_Allgatherv_int(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
+                                  displs, recvtype, comm, ierror)
+        use iso_c_binding, only: c_int, c_ptr, c_loc
+        use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
+        integer, dimension(:), intent(in), target :: sendbuf
+        integer, intent(in) :: sendcount
+        integer, intent(in) :: sendtype
+        integer, dimension(:), intent(out), target :: recvbuf
+        integer, dimension(:), intent(in) :: recvcounts
+        integer, dimension(:), intent(in) :: displs
+        integer, intent(in) :: recvtype
+        integer, intent(in) :: comm
+        integer, optional, intent(out) :: ierror
+        integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
+        type(c_ptr) :: c_sendbuf, c_recvbuf
+        integer(c_int) :: local_ierr
+
+        ! Handle sendbuf (support MPI_IN_PLACE)
+        if (sendbuf(1) == MPI_IN_PLACE) then
+            c_sendbuf = c_MPI_IN_PLACE
+        else
+            c_sendbuf = c_loc(sendbuf)
+        end if
+        c_recvbuf = c_loc(recvbuf)
+        c_sendtype = handle_mpi_datatype_f2c(sendtype)
+        c_recvtype = handle_mpi_datatype_f2c(recvtype)
+        c_comm = handle_mpi_comm_f2c(comm)
+
+        ! Call C MPI_Allgatherv
+        local_ierr = c_mpi_allgatherv(c_sendbuf, sendcount, c_sendtype, &
+                                      c_recvbuf, recvcounts, displs, c_recvtype, &
+                                      c_comm)
+
+        ! Handle error
+        if (present(ierror)) then
+            ierror = local_ierr
+        else if (local_ierr /= MPI_SUCCESS) then
+            print *, "MPI_Allgatherv failed with error code: ", local_ierr
+        end if
+        
+    end subroutine MPI_Allgatherv_int
+
+    subroutine MPI_Allgatherv_real(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
+                                      displs, recvtype, comm, ierror)
+        use iso_c_binding, only: c_int, c_ptr, c_loc
+        use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
+        real(8), dimension(:), intent(in), target :: sendbuf
+        integer, intent(in) :: sendcount
+        integer, intent(in) :: sendtype
+        real(8), dimension(:), intent(out), target :: recvbuf
+        integer, dimension(:), intent(in) :: recvcounts
+        integer, dimension(:), intent(in) :: displs
+        integer, intent(in) :: recvtype
+        integer, intent(in) :: comm
+        integer, optional, intent(out) :: ierror
+        integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
+        type(c_ptr) :: c_sendbuf, c_recvbuf
+        integer(c_int) :: local_ierr
+
+        if (sendbuf(1) == MPI_IN_PLACE) then
+            c_sendbuf = c_MPI_IN_PLACE
+        else
+            c_sendbuf = c_loc(sendbuf)
+        end if
+
+        c_recvbuf = c_loc(recvbuf)
+        c_sendtype = handle_mpi_datatype_f2c(sendtype)
+        c_recvtype = handle_mpi_datatype_f2c(recvtype)
+        c_comm = handle_mpi_comm_f2c(comm)
+
+        ! Call C MPI_Allgatherv
+        local_ierr = c_mpi_allgatherv(c_sendbuf, sendcount, c_sendtype, &
+                                      c_recvbuf, recvcounts, displs, c_recvtype, &
+                                      c_comm)
+
+        if (present(ierror)) then
+            ierror = local_ierr
+        else if (local_ierr /= MPI_SUCCESS) then
+            print *, "MPI_Allgatherv failed with error code: ", local_ierr
+        end if
+
+    end subroutine MPI_Allgatherv_real
+
     subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror)
         use iso_c_binding, only: c_int, c_ptr
         use mpi_c_bindings, only: c_mpi_ssend
diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90
index 6561693..d68dcd1 100644
--- a/src/mpi_c_bindings.f90
+++ b/src/mpi_c_bindings.f90
@@ -221,6 +221,20 @@ function c_mpi_cart_create(comm_old, ndims, dims, periods, reorder, comm_cart) b
             integer(c_int) :: c_mpi_cart_create
         end function
 
+        function c_mpi_allgatherv(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
+                                  displs, recvtype, comm) bind(C, name="MPI_Allgatherv")
+            use iso_c_binding, only: c_int, c_ptr
+            type(c_ptr), value :: sendbuf
+            integer(c_int), value :: sendcount
+            integer(kind=MPI_HANDLE_KIND), value :: sendtype
+            type(c_ptr), value :: recvbuf
+            integer(c_int), dimension(*) :: recvcounts
+            integer(c_int), dimension(*) :: displs
+            integer(kind=MPI_HANDLE_KIND), value :: recvtype
+            integer(kind=MPI_HANDLE_KIND), value :: comm
+            integer(c_int) :: c_mpi_allgatherv
+        end function c_mpi_allgatherv
+
         function c_mpi_cart_coords(comm, rank, maxdims, coords) bind(C, name="MPI_Cart_coords")
             use iso_c_binding,  only: c_int, c_ptr
             integer(kind=MPI_HANDLE_KIND), value :: comm
diff --git a/tests/allgatherv_1.f90 b/tests/allgatherv_1.f90
new file mode 100644
index 0000000..b8aaa24
--- /dev/null
+++ b/tests/allgatherv_1.f90
@@ -0,0 +1,59 @@
+program allgatherv_1
+    use mpi
+    implicit none
+    integer :: ierr, rank, size
+    integer, allocatable :: sendbuf(:), recvbuf(:)
+    integer, allocatable :: recvcounts(:), displs(:)
+    integer :: sendcount, i, total
+    logical :: error
+
+    ! Initialize MPI
+    call MPI_Init(ierr)
+    call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
+    call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
+
+    ! Each process sends 'rank + 1' integers
+    sendcount = rank + 1
+    allocate(sendbuf(sendcount))
+    do i = 1, sendcount
+        sendbuf(i) = rank * 100 + i  ! Unique values per process
+    end do
+
+    ! All processes allocate receive buffers
+    allocate(recvcounts(size))
+    allocate(displs(size))
+    total = 0
+    do i = 1, size
+        recvcounts(i) = i  ! Process i-1 sends i elements
+        displs(i) = total  ! Displacement in recvbuf
+        total = total + recvcounts(i)
+    end do
+    allocate(recvbuf(total))
+    recvbuf = 0
+
+    ! Perform allgather
+    call MPI_Allgatherv(sendbuf, sendcount, MPI_INTEGER, recvbuf, recvcounts, &
+                        displs, MPI_INTEGER, MPI_COMM_WORLD, ierr)
+
+    ! Verify results on all processes
+    error = .false.
+    do i = 1, size
+        do sendcount = 1, i
+            if (recvbuf(displs(i) + sendcount) /= (i-1)*100 + sendcount) then
+                print *, "Rank ", rank, ": Error at source rank ", i-1, &
+                         " index ", sendcount, ": expected ", (i-1)*100 + sendcount, &
+                         ", got ", recvbuf(displs(i) + sendcount)
+                error = .true.
+            end if
+        end do
+    end do
+    if (.not. error) then
+        print *, "MPI_Allgatherv test passed on rank ", rank
+    end if
+
+    ! Clean up
+    deallocate(sendbuf, recvbuf, recvcounts, displs)
+    call MPI_Finalize(ierr)
+
+    if (error) stop 1
+end program allgatherv_1
\ No newline at end of file


Reviews:
user: login: gxyd
body: Same concern I've with this PR as I mentioned in the other PR, i.e. we also need to make sure (by standalone tests) that the way the subroutine is used in pFUnit should be added as a standalone test case.

I see two uses of `MPI_Allgather_v` in pFUnit:
```f90
      call Mpi_allGatherV( &
           & values, size(values), MPI_INTEGER, &
           & global_list,   counts, displacements, MPI_INTEGER, &
           & this%mpiCommunicator, ier)
```

and the other is:
```f90
      call Mpi_AllgatherV( &
           & values_, size(values), MPI_LOGICAL, &
           & list,   counts, displacements, MPI_LOGICAL, &
           & this%mpiCommunicator, ier)
```

maybe we can ensure that we write test cases for different `MPI_types` and/or dimensions of array(s) (if any) 
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-05-20T06:17:46Z
user: login: adit4443ya
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-05-20T11:03:34Z
user: login: gxyd
body: Looks good to me, thanks @adit4443ya 
state: APPROVED
author_association: COLLABORATOR
submitted_at: 2025-05-21T06:12:38Z

Review comments:
diff_hunk: @@ -773,6 +778,89 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror)
 
     end subroutine MPI_Waitall_proc
 
+    subroutine MPI_Allgatherv_int(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
+                                  displs, recvtype, comm, ierror)
+        use iso_c_binding, only: c_int, c_ptr, c_loc
+        use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
+        integer, dimension(:), intent(in), target :: sendbuf
+        integer, intent(in) :: sendcount
+        integer, intent(in) :: sendtype
+        integer, dimension(:), intent(out), target :: recvbuf
+        integer, dimension(:), intent(in) :: recvcounts
+        integer, dimension(:), intent(in) :: displs
+        integer, intent(in) :: recvtype
+        integer, intent(in) :: comm
+        integer, optional, intent(out) :: ierror
+        integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
+        type(c_ptr) :: c_sendbuf, c_recvbuf
+        integer(c_int) :: local_ierr
+
+        ! Handle sendbuf (support MPI_IN_PLACE)
+        if (sendbuf(1) == MPI_IN_PLACE) then
+            c_sendbuf = c_MPI_IN_PLACE
+        else
+            c_sendbuf = c_loc(sendbuf)
+        end if
path: src/mpi.f90
user: login: gxyd
body: I think we should've a utility function for this now, which should do this work for us now.
created_at: 2025-05-20T06:14:39Z
author_association: COLLABORATOR
diff_hunk: @@ -773,6 +778,89 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror)
 
     end subroutine MPI_Waitall_proc
 
+    subroutine MPI_Allgatherv_int(sendbuf, sendcount, sendtype, recvbuf, recvcounts, &
+                                  displs, recvtype, comm, ierror)
+        use iso_c_binding, only: c_int, c_ptr, c_loc
+        use mpi_c_bindings, only: c_mpi_allgatherv, c_mpi_in_place
+        integer, dimension(:), intent(in), target :: sendbuf
+        integer, intent(in) :: sendcount
+        integer, intent(in) :: sendtype
+        integer, dimension(:), intent(out), target :: recvbuf
+        integer, dimension(:), intent(in) :: recvcounts
+        integer, dimension(:), intent(in) :: displs
+        integer, intent(in) :: recvtype
+        integer, intent(in) :: comm
+        integer, optional, intent(out) :: ierror
+        integer(kind=MPI_HANDLE_KIND) :: c_sendtype, c_recvtype, c_comm
+        type(c_ptr) :: c_sendbuf, c_recvbuf
+        integer(c_int) :: local_ierr
+
+        ! Handle sendbuf (support MPI_IN_PLACE)
+        if (sendbuf(1) == MPI_IN_PLACE) then
+            c_sendbuf = c_MPI_IN_PLACE
+        else
+            c_sendbuf = c_loc(sendbuf)
+        end if
path: src/mpi.f90
user: login: adit4443ya
body: Yes we can add utility function like we have for comm_world and other things. Will make a subsequent PR for that.
created_at: 2025-05-20T11:03:34Z
author_association: COLLABORATOR

PR comments:
user: login: adit4443ya
created_at: 2025-05-20T06:25:46Z
body: Thanks for posting it's usecase in pFUnit. I will do this in evening!!(ASAP), for both PRs
author_association: COLLABORATOR
user: login: adit4443ya
created_at: 2025-05-20T11:06:45Z
body: Why don't we do one thing, 
when CI issue gets resolved then merge this PRs and then i will add respective tests for both subroutines MPI_Gatherv and MPI_Allgatherv.

As  you mentioned the use case for them it includes the MPI_LOGICAL and MPI_CHARACTER datatype to be implemented which i would like to handle in separate PR.
so the flow would be 

Get CI fixed -> merge pending PRs -> Add bindings with LOGICAL and CHARACTER -> Add pfUnit like tests for both subroutines (which will invlove to add  subroutine which can take character arrays as an input ,currently it takes int/real(8) as input for `sendbuf` and `recvbuf`)

As doing all in these PRs would clutter things up
Let me know how that sounds.
author_association: COLLABORATOR
user: login: gxyd
created_at: 2025-05-20T12:30:29Z
body: > Get CI fixed -> merge pending PRs -> Add bindings with LOGICAL and CHARACTER -> Add pfUnit like tests for both subroutines (which will invlove to add subroutine which can take character arrays as an input ,currently it takes int/real(8) as input for `sendbuf` and `recvbuf`)

Yes, that's the idea. I just wanted you to be aware that I can't merge PR's for now, and any subsequent PR's might cause merge conflicts, which can be annoying sometimes.
author_association: COLLABORATOR
user: login: adit4443ya
created_at: 2025-05-20T15:53:25Z
body: Now the CI are fixed, Should we merge pending PRs (there  are 3 of them ) now? Need your approval
author_association: COLLABORATOR