From d9fadb58a75ff6ff0c75c59ee04f54a26f395997 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 02:23:48 +0530 Subject: [PATCH 1/5] Test: Add MPI_Recv Test --- tests/recv_1.f90 | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 tests/recv_1.f90 diff --git a/tests/recv_1.f90 b/tests/recv_1.f90 new file mode 100644 index 0000000..e745ac5 --- /dev/null +++ b/tests/recv_1.f90 @@ -0,0 +1,34 @@ +program test_recv_1 + use mpi + implicit none + + integer :: ierr, rank, size, comm, tag + real(8), dimension(5) :: buf + integer, dimension(MPI_STATUS_SIZE) :: status + + comm = MPI_COMM_WORLD + tag = 100 + + call MPI_Init(ierr) + call MPI_Comm_rank(comm, rank, ierr) + call MPI_Comm_size(comm, size, ierr) + + if (size < 2) then + print *, "This test works best with at least 2 MPI processes." + else + if (rank == 0) then + ! Rank 0: Prepare data and send synchronously. + buf = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /) + call MPI_Ssend(buf, 5, MPI_REAL8, 1, tag, comm, ierr) + print *, "Rank 0 sent data." + else if (rank == 1) then + ! Rank 1: Receive the data. + buf = 0.0d0 ! initialize to zeros + call MPI_Recv(buf, 5, MPI_REAL8, 0, tag, comm, status, ierr) + print *, "Rank 1 received data: ", buf + end if + end if + + call MPI_Finalize(ierr) + +end program test_recv_1 \ No newline at end of file From c4aa4052e916c2b98c8e28a2c808bc786364b2f7 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 02:28:52 +0530 Subject: [PATCH 2/5] Remove C-wrapper for MPI_Recv --- src/mpi.f90 | 43 ++++++++++++++++++++++++++++++++++-------- src/mpi_c_bindings.f90 | 27 +++++++++++++++++--------- 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index 80ed121..d4c0741 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -14,6 +14,7 @@ module mpi real(8), parameter :: MPI_IN_PLACE = -1002 integer, parameter :: MPI_SUM = -2300 integer, parameter :: MPI_INFO_NULL = -2000 + integer, parameter :: MPI_STATUS_SIZE = 5 integer :: MPI_STATUS_IGNORE = 0 ! NOTE: I've no idea for how to implement this, refer ! see section 2.5.4 page 21 of mpi40-report.pdf @@ -458,15 +459,41 @@ subroutine MPI_Comm_split_type_proc(comm, split_type, key, info, newcomm, ierror end subroutine subroutine MPI_Recv_proc(buf, count, datatype, source, tag, comm, status, ierror) - use mpi_c_bindings, only: c_mpi_recv - real(8), dimension(:) :: buf - integer, intent(in) :: count, source, tag - integer, intent(in) :: datatype - integer, intent(in) :: comm - integer, intent(out) :: status + use iso_c_binding, only: c_int, c_ptr, c_loc + use mpi_c_bindings, only: c_mpi_recv, c_mpi_comm_f2c, c_mpi_datatype_f2c, c_mpi_status_c2f + real(8), dimension(:), target, intent(inout) :: buf + integer, intent(in) :: count, source, tag, datatype, comm + integer, intent(out) :: status(MPI_STATUS_SIZE) integer, optional, intent(out) :: ierror - call c_mpi_recv(buf, count, datatype, source, tag, comm, status, ierror) - end subroutine + + integer(c_int) :: local_ierr, status_ierr + type(c_ptr) :: c_buf, c_dtype, c_comm, c_status + integer(c_int), dimension(MPI_STATUS_SIZE), target :: tmp_status + + ! Convert Fortran handles to C handles. + c_dtype = c_mpi_datatype_f2c(datatype) + c_comm = c_mpi_comm_f2c(comm) + + ! Get the pointer to the buffer. + c_buf = c_loc(buf) + ! Use a local temporary MPI_Status (as an array of c_int) + c_status = c_loc(tmp_status) + + ! Call the native MPI_Recv. + local_ierr = c_mpi_recv(c_buf, count, c_dtype, source, tag, c_comm, c_status) + + ! Convert the C MPI_Status to Fortran status. + if (local_ierr == MPI_SUCCESS) then + status_ierr = c_mpi_status_c2f(c_status, status) + end if + + if (present(ierror)) then + ierror = local_ierr + else if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Recv failed with error code: ", local_ierr + end if + + end subroutine MPI_Recv_proc subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) use mpi_c_bindings, only: c_mpi_waitall diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index a332b7d..db49ad0 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -32,6 +32,13 @@ function c_mpi_op_f2c(op_f) bind(C, name="get_c_op_from_fortran") type(c_ptr) :: c_mpi_op_f2c end function c_mpi_op_f2c + function c_mpi_status_c2f(c_status, f_status) bind(C, name="MPI_Status_c2f") + use iso_c_binding, only: c_ptr, c_int + type(c_ptr) :: c_status + integer(c_int) :: f_status(*) ! assumed-size array + integer(c_int) :: c_mpi_status_c2f + end function c_mpi_status_c2f + function c_mpi_init(argc, argv) bind(C, name="MPI_Init") use iso_c_binding, only : c_int, c_ptr !> TODO: is the intent need to be explicitly specified @@ -177,15 +184,17 @@ subroutine c_mpi_comm_split_type(comm, split_type, key, info, newcomm, ierror) b integer(c_int), optional, intent(out) :: ierror end subroutine - subroutine c_mpi_recv(buf, count, datatype, source, tag, comm, status, ierror) bind(C, name="mpi_recv_wrapper") - use iso_c_binding, only: c_int, c_double - real(c_double), dimension(*) :: buf - integer(c_int), intent(in) :: count, source, tag - integer(c_int), intent(in) :: datatype - integer(c_int), intent(in) :: comm - integer(c_int), intent(out) :: status - integer(c_int), optional, intent(out) :: ierror - end subroutine + function c_mpi_recv(buf, count, c_dtype, source, tag, c_comm, status) bind(C, name="MPI_Recv") + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: buf + integer(c_int), value :: count + type(c_ptr), value :: c_dtype + integer(c_int), value :: source + integer(c_int), value :: tag + type(c_ptr), value :: c_comm + type(c_ptr) :: status + integer(c_int) :: c_mpi_recv + end function c_mpi_recv subroutine c_mpi_waitall(count, array_of_requests, array_of_statuses, ierror) bind(C, name="mpi_waitall_wrapper") use iso_c_binding, only: c_int From 189991e904187fb191d1068b3b618259b7fc466b Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 16:13:38 +0530 Subject: [PATCH 3/5] Use real(c_double) instead of type(C_PTR) in bind(C) interface function for buffer data --- src/mpi.f90 | 8 +++----- src/mpi_c_bindings.f90 | 4 ++-- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index d4c0741..85697fa 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -461,26 +461,24 @@ subroutine MPI_Comm_split_type_proc(comm, split_type, key, info, newcomm, ierror subroutine MPI_Recv_proc(buf, count, datatype, source, tag, comm, status, ierror) use iso_c_binding, only: c_int, c_ptr, c_loc use mpi_c_bindings, only: c_mpi_recv, c_mpi_comm_f2c, c_mpi_datatype_f2c, c_mpi_status_c2f - real(8), dimension(:), target, intent(inout) :: buf + real(8), dimension(*), intent(inout) :: buf integer, intent(in) :: count, source, tag, datatype, comm integer, intent(out) :: status(MPI_STATUS_SIZE) integer, optional, intent(out) :: ierror integer(c_int) :: local_ierr, status_ierr - type(c_ptr) :: c_buf, c_dtype, c_comm, c_status + type(c_ptr) :: c_dtype, c_comm, c_status integer(c_int), dimension(MPI_STATUS_SIZE), target :: tmp_status ! Convert Fortran handles to C handles. c_dtype = c_mpi_datatype_f2c(datatype) c_comm = c_mpi_comm_f2c(comm) - ! Get the pointer to the buffer. - c_buf = c_loc(buf) ! Use a local temporary MPI_Status (as an array of c_int) c_status = c_loc(tmp_status) ! Call the native MPI_Recv. - local_ierr = c_mpi_recv(c_buf, count, c_dtype, source, tag, c_comm, c_status) + local_ierr = c_mpi_recv(buf, count, c_dtype, source, tag, c_comm, c_status) ! Convert the C MPI_Status to Fortran status. if (local_ierr == MPI_SUCCESS) then diff --git a/src/mpi_c_bindings.f90 b/src/mpi_c_bindings.f90 index db49ad0..4cf57c3 100644 --- a/src/mpi_c_bindings.f90 +++ b/src/mpi_c_bindings.f90 @@ -185,8 +185,8 @@ subroutine c_mpi_comm_split_type(comm, split_type, key, info, newcomm, ierror) b end subroutine function c_mpi_recv(buf, count, c_dtype, source, tag, c_comm, status) bind(C, name="MPI_Recv") - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), value :: buf + use iso_c_binding, only: c_ptr, c_int, c_double + real(c_double), dimension(*), intent(out) :: buf integer(c_int), value :: count type(c_ptr), value :: c_dtype integer(c_int), value :: source From de3169dd19237528d56c7b2bc21f0c13ec4ef6e3 Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 16:46:27 +0530 Subject: [PATCH 4/5] Add case for MPI_STATUS_IGNORE --- src/mpi.f90 | 42 +++++++++++++++++++++++++++++++++++++++--- src/mpi_wrapper.c | 12 ------------ 2 files changed, 39 insertions(+), 15 deletions(-) diff --git a/src/mpi.f90 b/src/mpi.f90 index b21a3e9..a341f1d 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -82,7 +82,8 @@ module mpi end interface interface MPI_Recv - module procedure MPI_Recv_proc + module procedure MPI_Recv_StatusArray_proc + module procedure MPI_Recv_StatusIgnore_proc end interface interface MPI_Waitall @@ -517,7 +518,7 @@ subroutine MPI_Comm_split_type_proc(comm, split_type, key, info, newcomm, ierror end subroutine MPI_Comm_split_type_proc - subroutine MPI_Recv_proc(buf, count, datatype, source, tag, comm, status, ierror) + subroutine MPI_Recv_StatusArray_proc(buf, count, datatype, source, tag, comm, status, ierror) use iso_c_binding, only: c_int, c_ptr, c_loc use mpi_c_bindings, only: c_mpi_recv, c_mpi_comm_f2c, c_mpi_datatype_f2c, c_mpi_status_c2f real(8), dimension(*), intent(inout) :: buf @@ -550,7 +551,42 @@ subroutine MPI_Recv_proc(buf, count, datatype, source, tag, comm, status, ierror print *, "MPI_Recv failed with error code: ", local_ierr end if - end subroutine MPI_Recv_proc + end subroutine MPI_Recv_StatusArray_proc + + subroutine MPI_Recv_StatusIgnore_proc(buf, count, datatype, source, tag, comm, status, ierror) + use iso_c_binding, only: c_int, c_ptr, c_loc + use mpi_c_bindings, only: c_mpi_recv, c_mpi_comm_f2c, c_mpi_datatype_f2c, c_mpi_status_c2f + real(8), dimension(*), intent(inout) :: buf + integer, intent(in) :: count, source, tag, datatype, comm + integer, intent(out) :: status + integer, optional, intent(out) :: ierror + + integer(c_int) :: local_ierr, status_ierr + type(c_ptr) :: c_dtype, c_comm, c_status + integer(c_int), dimension(MPI_STATUS_SIZE), target :: tmp_status + + ! Convert Fortran handles to C handles. + c_dtype = c_mpi_datatype_f2c(datatype) + c_comm = c_mpi_comm_f2c(comm) + + ! Use a local temporary MPI_Status (as an array of c_int) + c_status = c_loc(tmp_status) + + ! Call the native MPI_Recv. + local_ierr = c_mpi_recv(buf, count, c_dtype, source, tag, c_comm, c_status) + + ! Convert the C MPI_Status to Fortran status. + if (local_ierr == MPI_SUCCESS) then + ! status_ierr = c_mpi_status_c2f(c_status, status) + end if + + if (present(ierror)) then + ierror = local_ierr + else if (local_ierr /= MPI_SUCCESS) then + print *, "MPI_Recv failed with error code: ", local_ierr + end if + + end subroutine MPI_Recv_StatusIgnore_proc subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) use mpi_c_bindings, only: c_mpi_waitall diff --git a/src/mpi_wrapper.c b/src/mpi_wrapper.c index 25be0b4..0c9ca03 100644 --- a/src/mpi_wrapper.c +++ b/src/mpi_wrapper.c @@ -94,18 +94,6 @@ void mpi_allreduce_wrapper_int(const int *sendbuf, int *recvbuf, int *count, } } -void mpi_recv_wrapper(double *buf, int *count, int *datatype_f, int *source, - int *tag, int *comm_f, int *status_f, int *ierror) { - MPI_Datatype datatype = get_c_datatype_from_fortran(*datatype_f); - - MPI_Comm comm = get_c_comm_from_fortran(*comm_f); - MPI_Status status; - *ierror = MPI_Recv(buf, *count, datatype, *source, *tag, comm, &status); - if (*ierror == MPI_SUCCESS) { - MPI_Status_c2f(&status, status_f); - } -} - void mpi_waitall_wrapper(int *count, int *array_of_requests_f, int *array_of_statuses_f, int *ierror) { MPI_Request *array_of_requests; From 2c04af5e81cbc459d937570fd09fcfd3631bd79f Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 17:02:49 +0530 Subject: [PATCH 5/5] Temporarily use status array --- tests/ssend_1.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/ssend_1.f90 b/tests/ssend_1.f90 index 6a2afd0..fbedd5e 100644 --- a/tests/ssend_1.f90 +++ b/tests/ssend_1.f90 @@ -6,6 +6,7 @@ program ssend_example integer :: rank, size, ierr, i real(8) :: buffer(10) integer :: tag = 100 + integer, dimension(MPI_STATUS_SIZE) :: status ! allocate(buffer(10)) ! Initialize MPI environment @@ -47,7 +48,7 @@ program ssend_example buffer = 0 ! Receive the message - call MPI_Recv(buffer, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_Recv(buffer, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, status, ierr) print *, "Process 1: Received data:" ! write(*, '(10I5)') buffer