FEAT: Implment Wrappers of MPI_COMM_FREE

Author: adit4443ya

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

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

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