diff --git a/src/mpi.f90 b/src/mpi.f90 index a48ba26..0cc6410 100644 --- a/src/mpi.f90 +++ b/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 diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index 6561693..ce243d4 100644 --- a/src/mpi_c_bindings.f90 +++ b/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 diff --git a/tests/comm_dup_1.f90 b/tests/comm_dup_1.f90 new file mode 100644 index 0000000..1314fdc --- /dev/null +++ b/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