From 3c4f0d7cbb1b517b3a38206af4f9e07fa905828c Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 18:26:41 +0530 Subject: [PATCH 1/3] Handle 1D arrays for MPI_Ssend --- src/mpi.f90 | 21 +++++++++++++++++++-- tests/waitall_1.f90 | 44 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 2 deletions(-) create mode 100644 tests/waitall_1.f90 diff --git a/src/mpi.f90 b/src/mpi.f90 index a341f1d..4d571b8 100644 --- a/src/mpi.f90 +++ b/src/mpi.f90 @@ -91,7 +91,8 @@ module mpi end interface interface MPI_Ssend - module procedure MPI_Ssend_proc + module procedure MPI_Ssend_2D_proc + module procedure MPI_Ssend_1D_proc end interface interface MPI_Cart_create @@ -597,7 +598,7 @@ subroutine MPI_Waitall_proc(count, array_of_requests, array_of_statuses, ierror) call c_mpi_waitall(count, array_of_requests, array_of_statuses, ierror) end subroutine - subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror) + subroutine MPI_Ssend_1D_proc(buf, count, datatype, dest, tag, comm, ierror) use iso_c_binding, only: c_int, c_ptr use mpi_c_bindings, only: c_mpi_ssend, c_mpi_datatype_f2c, c_mpi_comm_f2c real(8), dimension(*), intent(in) :: buf @@ -613,6 +614,22 @@ subroutine MPI_Ssend_proc(buf, count, datatype, dest, tag, comm, ierror) local_ierr = c_mpi_ssend(buf, count, c_datatype, dest, tag, c_comm) end subroutine + subroutine MPI_Ssend_2D_proc(buf, count, datatype, dest, tag, comm, ierror) + use iso_c_binding, only: c_int, c_ptr + use mpi_c_bindings, only: c_mpi_ssend, c_mpi_datatype_f2c, c_mpi_comm_f2c + real(8), dimension(:,:), intent(in) :: buf + integer, intent(in) :: count, dest, tag + integer, intent(in) :: datatype + integer, intent(in) :: comm + integer, optional, intent(out) :: ierror + type(c_ptr) :: c_datatype, c_comm + integer :: local_ierr + + c_datatype = c_mpi_datatype_f2c(datatype) + c_comm = c_mpi_comm_f2c(comm) + local_ierr = c_mpi_ssend(buf, count, c_datatype, dest, tag, c_comm) + end subroutine + subroutine MPI_Cart_create_proc(comm_old, ndims, dims, periods, reorder, comm_cart, ierror) use iso_c_binding, only: c_int, c_ptr use mpi_c_bindings, only: c_mpi_cart_create, c_mpi_comm_f2c, c_mpi_comm_c2f diff --git a/tests/waitall_1.f90 b/tests/waitall_1.f90 new file mode 100644 index 0000000..b95c01e --- /dev/null +++ b/tests/waitall_1.f90 @@ -0,0 +1,44 @@ +program test_waitall + use mpi + implicit none + + integer :: ierr, rank, size, comm, tag + integer, parameter :: num_reqs = 2 + integer, dimension(num_reqs) :: reqs + real(8), dimension(10) :: buf1, buf2 + integer :: i + +! MPI_COMM_WORLD = 0 ! Assume MPI_COMM_WORLD is 0 in your Fortran binding + tag = 100 + + call MPI_Init(ierr) + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) + + if (size < 2) then + print *, "This test requires at least 2 MPI processes." + call MPI_Finalize(ierr) + else + if (rank == 0) then + ! Rank 0: send two messages using MPI_Ssend. + buf1 = (/ (i*1.0d0, i=1,10) /) + buf2 = (/ (i*10.0d0, i=1,10) /) + call MPI_Ssend(buf1, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) + call MPI_Ssend(buf2, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) + print *, "Rank 0 sent two messages." + else if (rank == 1) then + ! Rank 1: post two nonblocking receives. + ! (Assuming MPI_Irecv is implemented; if not, you could use a dummy wait.) + call MPI_Recv(buf1, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(1), ierr) + call MPI_Recv(buf2, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(2), ierr) + + ! Wait for both receives. + call MPI_Waitall(num_reqs, reqs, MPI_STATUSES_IGNORE, ierr) + + print *, "Rank 1 received buf1 =", buf1 + print *, "Rank 1 received buf2 =", buf2 + call MPI_Finalize(ierr) + end if +end if + +end program test_waitall \ No newline at end of file From b2d87452957045e029914cfc2300f7502eeb828d Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 18:26:57 +0530 Subject: [PATCH 2/3] Add MPI_WaitAll test --- tests/waitall_1.f90 | 87 +++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 42 deletions(-) diff --git a/tests/waitall_1.f90 b/tests/waitall_1.f90 index b95c01e..cab036b 100644 --- a/tests/waitall_1.f90 +++ b/tests/waitall_1.f90 @@ -1,44 +1,47 @@ -program test_waitall - use mpi - implicit none - - integer :: ierr, rank, size, comm, tag - integer, parameter :: num_reqs = 2 - integer, dimension(num_reqs) :: reqs - real(8), dimension(10) :: buf1, buf2 - integer :: i - -! MPI_COMM_WORLD = 0 ! Assume MPI_COMM_WORLD is 0 in your Fortran binding - tag = 100 - - call MPI_Init(ierr) - call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) - call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) - - if (size < 2) then - print *, "This test requires at least 2 MPI processes." - call MPI_Finalize(ierr) - else - if (rank == 0) then - ! Rank 0: send two messages using MPI_Ssend. - buf1 = (/ (i*1.0d0, i=1,10) /) - buf2 = (/ (i*10.0d0, i=1,10) /) - call MPI_Ssend(buf1, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) - call MPI_Ssend(buf2, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) - print *, "Rank 0 sent two messages." - else if (rank == 1) then - ! Rank 1: post two nonblocking receives. - ! (Assuming MPI_Irecv is implemented; if not, you could use a dummy wait.) - call MPI_Recv(buf1, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(1), ierr) - call MPI_Recv(buf2, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(2), ierr) - - ! Wait for both receives. - call MPI_Waitall(num_reqs, reqs, MPI_STATUSES_IGNORE, ierr) - - print *, "Rank 1 received buf1 =", buf1 - print *, "Rank 1 received buf2 =", buf2 - call MPI_Finalize(ierr) - end if -end if +program test_waitall + use mpi + implicit none + + integer :: ierr, rank, size, comm, tag + integer, parameter :: num_reqs = 2 + integer, dimension(num_reqs) :: reqs + ! For statuses, we need an array of size num_reqs * MPI_STATUS_SIZE. + integer, dimension(num_reqs*MPI_STATUS_SIZE) :: statuses + real(8), dimension(3,3) :: buf1, buf2 + integer :: i + + comm = 0 ! Assume MPI_COMM_WORLD is represented by 0 + 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 requires at least 2 MPI processes." + ! call MPI_Finalize(ierr) ! Remove stop and finalize + ! stop 1 + else + if (rank == 0) then + ! Rank 0 sends two messages using MPI_Ssend. + buf1 = reshape([(i, i=1, 9)], shape=(/3,3/)) + buf2 = reshape([(i, i=1, 9)], shape=(/3,3/)) + call MPI_Ssend(buf1, 10, MPI_REAL8, 1, tag, comm, ierr) + call MPI_Ssend(buf2, 10, MPI_REAL8, 1, tag, comm, ierr) + print *, "Rank 0 sent two messages." + else if (rank == 1) then + ! Rank 1 posts two nonblocking receives. + call MPI_Irecv(buf1, 10, MPI_REAL8, 0, tag, comm, reqs(1), ierr) + call MPI_Irecv(buf2, 10, MPI_REAL8, 0, tag, comm, reqs(2), ierr) + + ! Wait on both requests. + call MPI_Waitall(num_reqs, reqs, statuses, ierr) + + print *, "Rank 1 received buf1 =", buf1 + print *, "Rank 1 received buf2 =", buf2 + end if + end if + + call MPI_Finalize(ierr) end program test_waitall \ No newline at end of file From d4a4ced66cb801e0811b4e65069945fb1cd5c3be Mon Sep 17 00:00:00 2001 From: Aditya Trivedi Date: Wed, 2 Apr 2025 18:32:09 +0530 Subject: [PATCH 3/3] Use MPI_COMM_WORLD --- tests/waitall_1.f90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/tests/waitall_1.f90 b/tests/waitall_1.f90 index cab036b..c259c85 100644 --- a/tests/waitall_1.f90 +++ b/tests/waitall_1.f90 @@ -2,7 +2,7 @@ program test_waitall use mpi implicit none - integer :: ierr, rank, size, comm, tag + integer :: ierr, rank, size, tag integer, parameter :: num_reqs = 2 integer, dimension(num_reqs) :: reqs ! For statuses, we need an array of size num_reqs * MPI_STATUS_SIZE. @@ -10,12 +10,11 @@ program test_waitall real(8), dimension(3,3) :: buf1, buf2 integer :: i - comm = 0 ! Assume MPI_COMM_WORLD is represented by 0 tag = 100 call MPI_Init(ierr) - call MPI_Comm_rank(comm, rank, ierr) - call MPI_Comm_size(comm, size, ierr) + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) if (size < 2) then print *, "This test requires at least 2 MPI processes." @@ -26,13 +25,13 @@ program test_waitall ! Rank 0 sends two messages using MPI_Ssend. buf1 = reshape([(i, i=1, 9)], shape=(/3,3/)) buf2 = reshape([(i, i=1, 9)], shape=(/3,3/)) - call MPI_Ssend(buf1, 10, MPI_REAL8, 1, tag, comm, ierr) - call MPI_Ssend(buf2, 10, MPI_REAL8, 1, tag, comm, ierr) + call MPI_Ssend(buf1, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) + call MPI_Ssend(buf2, 10, MPI_REAL8, 1, tag, MPI_COMM_WORLD, ierr) print *, "Rank 0 sent two messages." else if (rank == 1) then ! Rank 1 posts two nonblocking receives. - call MPI_Irecv(buf1, 10, MPI_REAL8, 0, tag, comm, reqs(1), ierr) - call MPI_Irecv(buf2, 10, MPI_REAL8, 0, tag, comm, reqs(2), ierr) + call MPI_Irecv(buf1, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(1), ierr) + call MPI_Irecv(buf2, 10, MPI_REAL8, 0, tag, MPI_COMM_WORLD, reqs(2), ierr) ! Wait on both requests. call MPI_Waitall(num_reqs, reqs, statuses, ierr)