From 0dd7754413127b86ea2d9dd1fcfbbbf789719a6b Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Tue, 27 May 2025 23:06:42 +0530 Subject: [PATCH 1/4] Feat: Implement Wrappers of MPI_COMM_CREATE and MPI_GROUP_RANGE_INCL --- src/mpi.f90 | 59 +++++++++++++++++++++++++++++++++++++++++ src/mpi_c_bindings.f90 | 18 +++++++++++++ src/mpi_constants.c | 2 ++ tests/comm_create_1.f90 | 44 ++++++++++++++++++++++++++++++ 4 files changed, 123 insertions(+) create mode 100644 tests/comm_create_1.f90 diff --git a/src/mpi.f90 b/src/mpi.f90 index d5896d5..e741cea 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -17,6 +17,7 @@ module mpi integer, parameter :: MPI_SUCCESS = 0 integer, parameter :: MPI_COMM_WORLD = -1000 + integer, parameter :: MPI_COMM_NULL = -1001 real(8), parameter :: MPI_IN_PLACE = -1002 integer, parameter :: MPI_SUM = -2300 integer, parameter :: MPI_MAX = -2301 @@ -49,6 +50,10 @@ module mpi module procedure MPI_Comm_Group_proc end interface MPI_Comm_Group + interface MPI_Comm_create + module procedure MPI_Comm_create_proc + end interface MPI_Comm_create + interface MPI_Group_free module procedure MPI_Group_free_proc end interface MPI_Group_free @@ -57,6 +62,11 @@ module mpi module procedure MPI_Group_size_proc end interface MPI_Group_size + interface MPI_Group_range_incl + module procedure MPI_Group_range_incl_proc + end interface MPI_Group_range_incl + + interface MPI_Comm_dup module procedure MPI_Comm_dup_proc end interface MPI_Comm_dup @@ -350,6 +360,55 @@ subroutine MPI_Group_free_proc(group, ierror) end if end subroutine MPI_Group_free_proc + subroutine MPI_Group_range_incl_proc(group, n, ranks, newgroup, ierror) + use mpi_c_bindings, only: c_mpi_group_range_incl, c_mpi_group_f2c, c_mpi_comm_c2f, c_mpi_group_c2f + use iso_c_binding, only: c_int, c_ptr + integer, intent(in) :: group + integer, intent(in) :: n + integer, dimension(:), intent(in) :: ranks + integer, intent(out) :: newgroup + integer, optional, intent(out) :: ierror + integer(kind=MPI_HANDLE_KIND) :: c_group, c_newgroup + integer(c_int) :: local_ierr + + c_group = c_mpi_group_f2c(group) + local_ierr = c_mpi_group_range_incl(c_group, n, ranks, c_newgroup) + newgroup = c_mpi_group_c2f(c_newgroup) + + if (present(ierror)) then + ierror = local_ierr + else if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Group_incl failed with error code: ", local_ierr + end if + end subroutine MPI_Group_range_incl_proc + + subroutine MPI_Comm_create_proc(comm, group, newcomm, ierror) + use mpi_c_bindings, only: c_mpi_comm_create, c_mpi_comm_f2c, c_mpi_comm_c2f, c_mpi_group_f2c, c_mpi_comm_null + use iso_c_binding, only: c_int, c_ptr + integer, intent(in) :: comm + integer, intent(in) :: group + integer, intent(out) :: newcomm + integer, optional, intent(out) :: ierror + integer(kind=MPI_HANDLE_KIND) :: c_comm, c_group, c_newcomm + integer(c_int) :: local_ierr + + c_comm = handle_mpi_comm_f2c(comm) + c_group = c_mpi_group_f2c(group) + local_ierr = c_mpi_comm_create(c_comm, c_group, c_newcomm) + + if (c_newcomm == c_mpi_comm_null) then + newcomm = MPI_COMM_NULL + else + newcomm = c_mpi_comm_c2f(c_newcomm) + end if + + if (present(ierror)) then + ierror = local_ierr + else if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Comm_create failed with error code: ", local_ierr + end if + end subroutine MPI_Comm_create_proc + 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 diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index 47ac067..2b98f6a 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -17,6 +17,7 @@ module mpi_c_bindings integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_REAL") :: c_mpi_real integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_INT") :: c_mpi_int integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_COMM_WORLD") :: c_mpi_comm_world + integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_COMM_NULL") :: c_mpi_comm_null integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_SUM") :: c_mpi_sum integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_MAX") :: c_mpi_max integer(kind=MPI_HANDLE_KIND), bind(C, name="c_MPI_LOGICAL") :: c_mpi_logical @@ -338,5 +339,22 @@ function c_mpi_group_free(group) bind(C, name="MPI_Group_free") integer(c_int) :: c_mpi_group_free end function c_mpi_group_free + function c_mpi_group_range_incl(group, n, ranges, c_newgroup) bind(C, name="MPI_Group_range_incl") + use iso_c_binding, only: c_ptr, c_int + integer(kind=MPI_HANDLE_KIND), value :: group + integer(c_int), value :: n + integer(c_int), dimension(*) :: ranges + integer(kind=MPI_HANDLE_KIND) :: c_newgroup + integer(c_int) :: c_mpi_group_range_incl + end function c_mpi_group_range_incl + + function c_mpi_comm_create(comm, group, newcomm) bind(C, name="MPI_Comm_create") + use iso_c_binding, only: c_ptr, c_int + integer(kind=MPI_HANDLE_KIND), value :: comm + integer(kind=MPI_HANDLE_KIND), value :: group + integer(kind=MPI_HANDLE_KIND), intent(out) :: newcomm + integer(c_int) :: c_mpi_comm_create + end function c_mpi_comm_create + end interface end module mpi_c_bindings diff --git a/src/mpi_constants.c b/src/mpi_constants.c index 48b8929..b343f4b 100644 --- a/src/mpi_constants.c +++ b/src/mpi_constants.c @@ -23,3 +23,5 @@ MPI_Datatype c_MPI_LOGICAL = MPI_LOGICAL; MPI_Datatype c_MPI_CHARACTER = MPI_CHARACTER; MPI_Datatype c_MPI_REAL = MPI_REAL; + +MPI_Comm c_MPI_COMM_NULL = MPI_COMM_NULL; \ No newline at end of file diff --git a/tests/comm_create_1.f90 b/tests/comm_create_1.f90 new file mode 100644 index 0000000..1ee762b --- /dev/null +++ b/tests/comm_create_1.f90 @@ -0,0 +1,44 @@ +program minimal_mre_range + use mpi + implicit none + + integer :: ierr, rank, size + integer :: group_world, group_range, new_comm + integer, dimension(3) :: range ! 1D array to define a single range + integer, dimension(3) :: range_2d + integer :: i + + call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr) + + ! Get the group of MPI_COMM_WORLD + call MPI_COMM_GROUP(MPI_COMM_WORLD, group_world, ierr) + + ! Define 1D range: start, end, stride + range(1) = 0 ! start + range(2) = size - 1 ! end + range(3) = 1 ! stride + + ! Convert 1D range to 2D required by MPI_GROUP_RANGE_INCL + range_2d(:) = range + + ! Create a new group that includes all ranks + call MPI_GROUP_RANGE_INCL(group_world, 1, range_2d, group_range, ierr) + + ! Create new communicator + call MPI_COMM_CREATE(MPI_COMM_WORLD, group_range, new_comm, ierr) + + ! Print participation + if (new_comm /= MPI_COMM_NULL) then + print *, 'Rank', rank, 'is in the new communicator.' + else + print *, 'Rank', rank, 'is NOT in the new communicator.' + end if + + ! Free groups (no comm_free) + call MPI_GROUP_FREE(group_range, ierr) + call MPI_GROUP_FREE(group_world, ierr) + + call MPI_FINALIZE(ierr) +end program minimal_mre_range \ No newline at end of file From bd47be772453ff6e0b94bdc1315efb8c85798973 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 28 May 2025 00:08:32 +0530 Subject: [PATCH 2/4] Update test --- tests/comm_create_1.f90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/tests/comm_create_1.f90 b/tests/comm_create_1.f90 index 1ee762b..31950be 100644 --- a/tests/comm_create_1.f90 +++ b/tests/comm_create_1.f90 @@ -5,7 +5,6 @@ program minimal_mre_range integer :: ierr, rank, size integer :: group_world, group_range, new_comm integer, dimension(3) :: range ! 1D array to define a single range - integer, dimension(3) :: range_2d integer :: i call MPI_INIT(ierr) @@ -20,11 +19,9 @@ program minimal_mre_range range(2) = size - 1 ! end range(3) = 1 ! stride - ! Convert 1D range to 2D required by MPI_GROUP_RANGE_INCL - range_2d(:) = range ! Create a new group that includes all ranks - call MPI_GROUP_RANGE_INCL(group_world, 1, range_2d, group_range, ierr) + call MPI_GROUP_RANGE_INCL(group_world, 1, range, group_range, ierr) ! Create new communicator call MPI_COMM_CREATE(MPI_COMM_WORLD, group_range, new_comm, ierr) From 81c2d04ddd7a3d97a117930dcebb49cd6dea2cea Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 28 May 2025 00:25:37 +0530 Subject: [PATCH 3/4] Fix: Support 2D ranges array --- src/mpi.f90 | 2 +- tests/comm_create_1.f90 | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index e741cea..e6231ed 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -365,7 +365,7 @@ subroutine MPI_Group_range_incl_proc(group, n, ranks, newgroup, ierror) use iso_c_binding, only: c_int, c_ptr integer, intent(in) :: group integer, intent(in) :: n - integer, dimension(:), intent(in) :: ranks + integer, dimension(:,:), intent(in) :: ranks integer, intent(out) :: newgroup integer, optional, intent(out) :: ierror integer(kind=MPI_HANDLE_KIND) :: c_group, c_newgroup diff --git a/tests/comm_create_1.f90 b/tests/comm_create_1.f90 index 31950be..04973ac 100644 --- a/tests/comm_create_1.f90 +++ b/tests/comm_create_1.f90 @@ -4,7 +4,7 @@ program minimal_mre_range integer :: ierr, rank, size integer :: group_world, group_range, new_comm - integer, dimension(3) :: range ! 1D array to define a single range + integer, dimension(1,3) :: range ! 1D array to define a single range integer :: i call MPI_INIT(ierr) @@ -15,9 +15,9 @@ program minimal_mre_range call MPI_COMM_GROUP(MPI_COMM_WORLD, group_world, ierr) ! Define 1D range: start, end, stride - range(1) = 0 ! start - range(2) = size - 1 ! end - range(3) = 1 ! stride + range(1,1) = 0 ! start + range(1,2) = size - 1 ! end + range(1,3) = 1 ! stride ! Create a new group that includes all ranks From e5a3d7c0c05e9fc8f5f0e5b0a2c8075304dcaf3c Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Thu, 29 May 2025 11:10:17 +0530 Subject: [PATCH 4/4] Apply code review --- src/mpi.f90 | 16 +++++++++++----- src/mpi_constants.c | 20 +++++++++++++------- tests/comm_create_1.f90 | 6 ++++-- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index e6231ed..d8e64f2 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -185,6 +185,16 @@ integer(kind=MPI_HANDLE_KIND) function handle_mpi_comm_f2c(comm_f) result(c_comm end if end function handle_mpi_comm_f2c + integer(kind=MPI_HANDLE_KIND) function handle_mpi_comm_c2f(comm_c) result(f_comm) + use mpi_c_bindings, only: c_mpi_comm_c2f, c_mpi_comm_null + integer(kind=mpi_handle_kind), intent(in) :: comm_c + if (comm_c == c_mpi_comm_null) then + f_comm = MPI_COMM_NULL + else + f_comm = c_mpi_comm_c2f(comm_c) + end if + end function handle_mpi_comm_c2f + integer(kind=MPI_HANDLE_KIND) function handle_mpi_info_f2c(info_f) result(c_info) use mpi_c_bindings, only: c_mpi_info_f2c, c_mpi_info_null integer, intent(in) :: info_f @@ -396,11 +406,7 @@ subroutine MPI_Comm_create_proc(comm, group, newcomm, ierror) c_group = c_mpi_group_f2c(group) local_ierr = c_mpi_comm_create(c_comm, c_group, c_newcomm) - if (c_newcomm == c_mpi_comm_null) then - newcomm = MPI_COMM_NULL - else - newcomm = c_mpi_comm_c2f(c_newcomm) - end if + newcomm = handle_mpi_comm_c2f(c_newcomm) if (present(ierror)) then ierror = local_ierr diff --git a/src/mpi_constants.c b/src/mpi_constants.c index b343f4b..fde0534 100644 --- a/src/mpi_constants.c +++ b/src/mpi_constants.c @@ -4,7 +4,9 @@ MPI_Status* c_MPI_STATUSES_IGNORE = MPI_STATUSES_IGNORE; MPI_Info c_MPI_INFO_NULL = MPI_INFO_NULL; -MPI_Comm c_MPI_COMM_WORLD = MPI_COMM_WORLD; +void* c_MPI_IN_PLACE = MPI_IN_PLACE; + +// DataType Declarations MPI_Datatype c_MPI_DOUBLE = MPI_DOUBLE; @@ -12,16 +14,20 @@ MPI_Datatype c_MPI_FLOAT = MPI_FLOAT; MPI_Datatype c_MPI_INT = MPI_INT; -void* c_MPI_IN_PLACE = MPI_IN_PLACE; +MPI_Datatype c_MPI_LOGICAL = MPI_LOGICAL; + +MPI_Datatype c_MPI_CHARACTER = MPI_CHARACTER; + +MPI_Datatype c_MPI_REAL = MPI_REAL; + +// Operation Declarations MPI_Op c_MPI_SUM = MPI_SUM; MPI_Op c_MPI_MAX = MPI_MAX; -MPI_Datatype c_MPI_LOGICAL = MPI_LOGICAL; - -MPI_Datatype c_MPI_CHARACTER = MPI_CHARACTER; +// Communicators Declarations -MPI_Datatype c_MPI_REAL = MPI_REAL; +MPI_Comm c_MPI_COMM_NULL = MPI_COMM_NULL; -MPI_Comm c_MPI_COMM_NULL = MPI_COMM_NULL; \ No newline at end of file +MPI_Comm c_MPI_COMM_WORLD = MPI_COMM_WORLD; \ No newline at end of file diff --git a/tests/comm_create_1.f90 b/tests/comm_create_1.f90 index 04973ac..f08e781 100644 --- a/tests/comm_create_1.f90 +++ b/tests/comm_create_1.f90 @@ -2,7 +2,7 @@ program minimal_mre_range use mpi implicit none - integer :: ierr, rank, size + integer :: ierr, rank, new_rank, size integer :: group_world, group_range, new_comm integer, dimension(1,3) :: range ! 1D array to define a single range integer :: i @@ -28,7 +28,9 @@ program minimal_mre_range ! Print participation if (new_comm /= MPI_COMM_NULL) then - print *, 'Rank', rank, 'is in the new communicator.' + call MPI_COMM_RANK(new_comm, new_rank, ierr) + if (ierr /= MPI_SUCCESS) error stop "MPI_COMM_RANK on new_comm failed" + print *, 'Global rank', rank, 'is in new_comm with local rank', new_rank else print *, 'Rank', rank, 'is NOT in the new communicator.' end if