feat: implement wrappers for MPI_Comm_dup

src/mpi.f90

@@ -41,6 +41,10 @@ module mpi
         module procedure MPI_Comm_size_proc
     end interface MPI_Comm_size
 
+    interface MPI_Comm_dup
+        module procedure MPI_Comm_dup_proc
+    end interface MPI_Comm_dup
+
     interface MPI_Bcast
         module procedure MPI_Bcast_int_scalar
         module procedure MPI_Bcast_real_2D
@@ -247,6 +251,28 @@ subroutine MPI_Comm_size_proc(comm, size, ierror)
         end if
     end subroutine
 
+    subroutine MPI_Comm_dup_proc(comm, newcomm, ierror)
+        use mpi_c_bindings, only: c_mpi_comm_dup, c_mpi_comm_c2f
+        integer, intent(in) :: comm
+        integer, intent(out) :: newcomm
+        integer, optional, intent(out) :: ierror
+
+        integer(kind=MPI_HANDLE_KIND) :: c_new_comm, c_comm
+        integer :: local_ierr
+
+        c_comm = handle_mpi_comm_f2c(comm)
+        local_ierr = c_mpi_comm_dup(c_comm, c_new_comm)
+        newcomm = c_mpi_comm_c2f(c_new_comm)
+
+        if (present(ierror)) then
+            ierror = local_ierr
+        else
+            if (local_ierr /= 0) then
+                print *, "MPI_Comm_dup failed with error code: ", local_ierr
+            end if
+        end if
+    end subroutine
+
     subroutine MPI_Bcast_int_scalar(buffer, count, datatype, root, comm, ierror)
         use mpi_c_bindings, only: c_mpi_bcast
         use iso_c_binding, only: c_int, c_ptr, c_loc

src/mpi_c_bindings.f90

@@ -93,6 +93,13 @@ function c_mpi_comm_size(comm, size) bind(C, name="MPI_Comm_size")
             integer(c_int) :: c_mpi_comm_size
         end function c_mpi_comm_size
 
+        function c_mpi_comm_dup(comm, newcomm) bind(C, name="MPI_Comm_dup")
+            use iso_c_binding, only: c_int
+            integer(kind=MPI_HANDLE_KIND), value :: comm
+            integer(kind=MPI_HANDLE_KIND), intent(out) :: newcomm
+            integer(c_int) :: c_mpi_comm_dup
+        end function
+
         function c_mpi_bcast(buffer, count, datatype, root, comm) bind(C, name="MPI_Bcast")
             use iso_c_binding, only : c_ptr, c_int
             type(c_ptr), value :: buffer

tests/comm_dup_1.f90

@@ -0,0 +1,42 @@
+program comm_dup_1
+    use mpi
+    implicit none
+
+    integer :: communicator, new_comm
+    integer :: ier, rank, size, received
+    type :: context_t
+        integer :: mpi_communicator
+    end type context_t
+
+    type(context_t) :: context
+
+    call MPI_Init(ier)
+
+    communicator = MPI_COMM_WORLD
+    call MPI_Comm_rank(communicator, rank, ier)
+    call MPI_Comm_size(communicator, size, ier)
+
+    call MPI_Comm_dup(communicator, context%mpi_communicator, ier)
+
+    if (ier /= MPI_SUCCESS) then
+        print *, "Error duplicating communicator"
+        error stop
+        ! call MPI_Abort(communicator, 1, ier)
+    end if
+
+    new_comm = context%mpi_communicator
+
+    print *, 'Process ', rank, ' of ', size, ' has duplicated communicator ', new_comm
+
+    if (rank == 0) then
+        ! call MPI_Send(42, 1, MPI_Integer, 1, 99, new_comm, ier)
+        print *, "Process 0 sent message using duplicated communicator"
+    else if (rank == 1) then
+        ! call MPI_Recv(received, 1, MPI_Integer, 0, 99, new_comm, MPI_STATUS_IGNORE, ier)
+        print *, 'Process 1 received: ', received, ' using duplicated communicator'
+    end if
+
+    ! call MPI_Comm_free(new_comm, ier)
+
+    call MPI_Finalize(ier)
+end program