program MPI3_5
use mpi
implicit none
integer, parameter :: kd = kind(1.0d0)
integer, parameter :: MAX_ROWS = 1000, MAX_COLS = 1000
integer :: rows, cols
real(kd) :: a(MAX_ROWS, MAX_COLS), b(MAX_COLS)
real(kd) :: c(MAX_ROWS), buffer(MAX_COLS), ans
integer :: myid, manager, numprocs, ierr, status(MPI_STATUS_SIZE)
integer :: i, j, numsent, sender
integer :: anstype, row
call MPI_INIT(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
manager = 0
rows = 100
cols = 100
if (myid == manager) then
do j = 1, cols
b(j) = 1
do i = 1, rows
a(i, j) = i
end do
end do
numsent = 0
call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)
do i = 1, min(numprocs - 1, rows)
do j = 1, cols
buffer(j) = a(i, j)
end do
call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, i, i, MPI_COMM_WORLD, ierr)
numsent = numsent + 1
end do
do i = 1, rows
call MPI_RECV(ans, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
sender = status(MPI_SOURCE)
anstype = status(MPI_TAG)
c(anstype) = ans
if (numsent < rows) then
do j = 1, cols
buffer(j) = a(numsent + 1, j)
end do
call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, sender, numsent + 1, MPI_COMM_WORLD, ierr)
numsent = numsent + 1
else
call MPI_SEND(MPI_BOTTOM, 0, MPI_DOUBLE_PRECISION, sender, 0, MPI_COMM_WORLD, ierr)
end if
end do
else
call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)
if (myid <= rows) then
do
call MPI_RECV(buffer, cols, MPI_DOUBLE_PRECISION, manager, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
if (status(MPI_TAG) == 0) exit
row = status(MPI_TAG)
ans = 0.0_kd
do i = 1, cols
ans = ans + buffer(i) * b(i)
end do
call MPI_SEND(ans, 1, MPI_DOUBLE_PRECISION, manager, row, MPI_COMM_WORLD, ierr)
end do
end if
end if
call MPI_FINALIZE(ierr)
if (myid == 0) print *, c(:cols)
end program MPI3_5
