diff --git a/src/mpi.f90 b/src/mpi.f90 index d8e64f2..73bf72e 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -71,6 +71,10 @@ module mpi module procedure MPI_Comm_dup_proc end interface MPI_Comm_dup + interface MPi_Comm_free + module procedure MPI_Comm_free_proc + end interface MPI_Comm_free + interface MPI_Bcast module procedure MPI_Bcast_int_scalar module procedure MPI_Bcast_real_2D @@ -435,7 +439,29 @@ subroutine MPI_Comm_dup_proc(comm, newcomm, ierror) print *, "MPI_Comm_dup failed with error code: ", local_ierr end if end if - end subroutine + end subroutine MPI_Comm_dup_proc + + subroutine MPI_Comm_free_proc(comm, ierror) + use mpi_c_bindings, only: c_mpi_comm_free, c_mpi_comm_f2c + integer, intent(inout) :: comm + integer, optional, intent(out) :: ierror + integer(kind=MPI_HANDLE_KIND) :: c_comm + integer :: local_ierr + + c_comm = handle_mpi_comm_f2c(comm) + local_ierr = c_mpi_comm_free(c_comm) + comm = handle_mpi_comm_c2f(c_comm) + + if (present(ierror)) then + ierror = local_ierr + else + if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Comm_free failed with error code: ", local_ierr + end if + end if + + comm = MPI_COMM_NULL ! Set to null after freeing + end subroutine MPI_Comm_free_proc subroutine MPI_Bcast_int_scalar(buffer, count, datatype, root, comm, ierror) use mpi_c_bindings, only: c_mpi_bcast diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index 2b98f6a..05b4f8e 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -356,5 +356,11 @@ function c_mpi_comm_create(comm, group, newcomm) bind(C, name="MPI_Comm_create") integer(c_int) :: c_mpi_comm_create end function c_mpi_comm_create + function c_mpi_comm_free(comm) bind(C, name="MPI_Comm_free") + use iso_c_binding, only: c_ptr, c_int + integer(kind=MPI_HANDLE_KIND), intent(inout) :: comm + integer(c_int) :: c_mpi_comm_free + end function c_mpi_comm_free + end interface end module mpi_c_bindings diff --git a/tests/comm_free_1.f90 b/tests/comm_free_1.f90 new file mode 100644 index 0000000..9f3a603 --- /dev/null +++ b/tests/comm_free_1.f90 @@ -0,0 +1,32 @@ +program mre_comm_free + use mpi + implicit none + + integer :: ierr, rank, size + integer :: dup_comm, dup_rank, dup_size + + call MPI_INIT(ierr) + if (ierr /= MPI_SUCCESS) error stop "MPI_INIT failed" + + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr) + + ! Create a duplicate communicator (all processes participate) + call MPI_COMM_DUP(MPI_COMM_WORLD, dup_comm, ierr) + if (ierr /= MPI_SUCCESS) error stop "MPI_COMM_DUP failed" + + ! Use the new communicator + call MPI_COMM_RANK(dup_comm, dup_rank, ierr) + call MPI_COMM_SIZE(dup_comm, dup_size, ierr) + + print *, 'Original Rank:', rank, ' -> Duplicate Rank:', dup_rank, & + ' / Size:', dup_size + + ! Free the duplicated communicator + call MPI_COMM_FREE(dup_comm, ierr) + if (ierr /= MPI_SUCCESS) error stop "MPI_COMM_FREE failed" + + print *, 'Rank', rank, 'successfully freed dup_comm.' + + call MPI_FINALIZE(ierr) +end program mre_comm_free \ No newline at end of file