Skip to content

Instantly share code, notes, and snippets.

@plampite
Created May 9, 2022 21:23
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save plampite/183e3705be4de4d1489feaf17c8e8a6a to your computer and use it in GitHub Desktop.
A Fortran example of a reduce step in MPI implemented trough simple mpi_send/recv calls. Useful when using mpi_type_create_struct and mpi_op create might be unconvenient or impossible. This version uses the basic binomial tree algorithm in MPICH.
program myreduce2
!Program to show a simple implementation of mpi_reduce, with only mpi_send/recv
!Useful for cases where one would need mpi_type_create_struct and mpi_op_create to achieve the same result
!This version uses the same MPICH binomial tree algorithm (order from 0 to nproc-1), which allows an easy
!customization of the processing order (just map each process to a different id)
!Here it is tested against the simple MPI intrinsic MPI_SUM on a single real variable
use, intrinsic :: iso_fortran_env, only : int32, real64
use mpi
implicit none
integer(int32) :: i, nstep, ppd, myp, nproc, myid, mpi_err, mpi_stat(mpi_status_size)
real(real64) :: x, xr1, xr2, xr
!Initialize MPI
call mpi_init(mpi_err)
call mpi_comm_size(mpi_comm_world,nproc,mpi_err)
call mpi_comm_rank(mpi_comm_world,myid,mpi_err)
!The local variable we want to reduce
call random_number(x)
!The reduce by the actual mpi_reduce, used as reference (MPI_SUM to match the example below)
call mpi_reduce(x,xr1,1,mpi_double_precision,mpi_sum,0,mpi_comm_world,mpi_err)
!Determine the number of steps in the algorithm (ceil(log_2(nproc)))
nstep = ceiling(log(real(nproc,real64))/log(2.0_real64),int32)
!Initiallze variables
xr2 = x
ppd = 1
!At each iteration, we move along the bit pattern of myid from right to left. If the given bit is set to 1,
!we send to the process that has the same bit set to 0 and exit. If it is set to 0 we receive from the process
!that has the same bit set to 1 and reduce (if that process is within nproc). At each iteration the number of
!involved processes is roughly halved until proc 0 will be the only one holding the fully reduced result
do i = 1, nstep
if (iand(myid,ppd)==0) then
myp = ior(myid,ppd)
if (myp<nproc) then
call mpi_recv(xr,1,mpi_double_precision,myp,i,mpi_comm_world,mpi_stat,mpi_err)
xr2 = xr2 + xr !insert your reduce here
endif
else
myp = iand(myid,not(ppd))
call mpi_send(xr2,1,mpi_double_precision,myp,i,mpi_comm_world,mpi_err)
exit
endif
ppd = ppd*2
enddo
!Check the end result against the MPI one
if (myid==0) write(*,'(a,g0)') "DIFF: ", (xr1-xr2)
!Finalize MPI
call mpi_finalize(mpi_err)
endprogram myreduce2
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment