prg_parallel_mod.F90

Go to the documentation of this file.

 
!
!
 
module prg_parallel_mod
 
  use bml
 
#ifdef DO_MPI
  use mpi
#endif
 
#ifdef DO_MPI
#ifdef SINGLE
#define REAL_MPI_TYPE MPI_FLOAT
#else
#define REAL_MPI_TYPE MPI_DOUBLE
#endif
#endif
 
  implicit none
 
  private  !Everything is private by default
 
  integer, parameter :: dp = kind(1.0d0)
 
  integer :: myrank, nranks
  integer :: ierr, reqcount
  integer, allocatable :: requestlist(:), rused(:)
 
  public :: rankreducedata_t
  public :: getnranks
  public :: getmyrank
  public :: printrank
  public :: prg_initparallel
  public :: prg_shutdownparallel
  public :: prg_barrierparallel
  public :: sendreceiveparallel
  public :: isendparallel
  public :: sendparallel
  public :: prg_iprg_recvparallel
  public :: prg_recvparallel
  public :: sumintparallel
  public :: sumrealparallel
  public :: maxintparallel
  public :: maxrealparallel
  public :: minintparallel
  public :: minrealparallel
  public :: prg_minrealreduce
  public :: prg_maxrealreduce
  public :: prg_maxintreduce2
  public :: prg_sumintreduce2
  public :: prg_sumintreducen
  public :: prg_sumrealreduce
  public :: prg_sumrealreduce2
  public :: prg_sumrealreduce3
  public :: prg_sumrealreducen
  public :: minrankrealparallel
  public :: maxrankrealparallel
  public :: prg_bcastparallel
  public :: allgatherrealparallel
  public :: allgatherintparallel
  public :: allgathervrealparallel
  public :: allgathervintparallel
  public :: prg_allsumrealreduceparallel
  public :: prg_allsumintreduceparallel
  public :: prg_allgatherparallel
  public :: prg_wait
 
  type rankreducedata_t
 
    real(dp) :: val
 
    integer :: rank
 
  end type rankreducedata_t
 
contains
 
  !
  ! Return total number of ranks
  !
  function getnranks() result(nR)
    integer :: nr
 
    nr = nranks
    return
 
  end function getnranks
 
  !
  ! Return the local rank
  !
  function getmyrank() result(mR)
    integer :: mr
 
    mr = myrank
 
    return
 
  end function getmyrank
 
  !
  ! Check if this is rank 0 for printing
  !
  function printrank() result(pR)
    integer :: pr
 
    pr = 0
 
    if (myrank .eq. 0) then
      pr = 1
    endif
 
    return
 
  end function printrank
 
  !
  ! Initialize MPI
  !
  subroutine prg_initparallel()
 
#ifdef DO_MPI
    call mpi_init(ierr)
    call mpi_comm_rank(mpi_comm_world, myrank, ierr)
    call mpi_comm_size(mpi_comm_world, nranks, ierr)
 
    call bml_initf(mpi_comm_world)
 
    !    if (printRank() .eq. 1) then
    write(*,*) "MPI started in progress, rank ", myrank, " out of ", nranks, " ranks"
    !    endif
 
#else
    myrank = 0
    nranks = 1
#endif
 
    allocate(requestlist(nranks))
    allocate(rused(nranks))
    rused = 0
 
  end subroutine prg_initparallel
 
  !
  ! Shutdown MPI
  !
  subroutine prg_shutdownparallel()
 
    deallocate(requestlist)
    deallocate(rused)
 
#ifdef DO_MPI
    call bml_shutdownf()
 
    call mpi_finalize(ierr)
#endif
 
  end subroutine prg_shutdownparallel
 
  !
  ! Save request
  !
  function saverequest(irequest)
 
    integer :: saverequest
    integer,intent(in) :: irequest
    integer :: i
 
#ifdef DO_MPI
    do i = 1, nranks
      if (rused(i) == 0) then
        requestlist(i) = irequest
        rused(i) = 1
 
        saverequest = i
        return
      endif
    enddo
#endif
 
    saverequest = -1
    return
 
  end function saverequest
 
  !
  ! Barrier - all ranks synchronized
  !
  subroutine prg_barrierparallel()
 
#ifdef DO_MPI
    call mpi_barrier(mpi_comm_world, ierr)
#endif
 
  end subroutine prg_barrierparallel
 
  !
  ! Coordinated send and receive
  !
  subroutine sendreceiveparallel(sendBuf, sendLen, dest, recvBuf, recvLen, source, nreceived)
 
    real(dp), intent(in) :: sendbuf(*)
    real(dp), intent(out) :: recvbuf(*)
    integer, intent(in) :: sendlen, recvlen, dest, source
    integer, intent(out) :: nreceived
#ifdef DO_MPI
    integer :: mstatus(mpi_status_size)
 
    call mpi_sendrecv(sendbuf, sendlen, real_mpi_type, dest, 0, &
         recvbuf, recvlen, real_mpi_type, source, 0, &
         mpi_comm_world, mstatus, ierr)
    call mpi_get_count(mstatus, real_mpi_type, nreceived, ierr)
#else
    recvbuf(1:sendlen) = sendbuf(1:sendlen)
    nreceived = sendlen
#endif
 
  end subroutine sendreceiveparallel
 
  !
  ! Non-blocking send
  !
  subroutine isendparallel(sendBuf, sendLen, dest)
 
    real(dp),intent(in) :: sendbuf(*)
    integer,intent(in) :: sendlen, dest
    integer :: request
 
#ifdef DO_MPI
    call mpi_isend(sendbuf, sendlen, real_mpi_type, dest, &
         0, mpi_comm_world, request, ierr)
#endif
 
  end subroutine isendparallel
 
  !
  ! Blocking send
  !
  subroutine sendparallel(sendBuf, sendLen, dest)
 
    real(dp),intent(in) :: sendbuf(*)
    integer,intent(in) :: sendlen, dest
 
#ifdef DO_MPI
    call mpi_send(sendbuf, sendlen, real_mpi_type, dest, &
         0, mpi_comm_world, ierr)
#endif
 
  end subroutine sendparallel
 
  !
  ! Non-blocking receive from any other rank
  !
  subroutine prg_iprg_recvparallel(recvBuf, recvLen, rind)
 
    real(dp) :: recvbuf(*)
    integer,intent(in) :: recvlen
    integer :: rind
#ifdef DO_MPI
    integer :: request
 
    call mpi_irecv(recvbuf, recvlen, real_mpi_type, mpi_any_source, &
         0, mpi_comm_world, request, ierr)
    rind = saverequest(request)
#endif
 
  end subroutine prg_iprg_recvparallel
 
  !
  ! Blocking receive from any other rank
  !
  subroutine prg_recvparallel(recvBuf, recvLen)
 
    real(dp) :: recvbuf(*)
    integer,intent(in) :: recvlen
#ifdef DO_MPI
    integer :: mstatus(mpi_status_size)
 
    call mpi_recv(recvbuf, recvlen, real_mpi_type, mpi_any_source, &
         0, mpi_comm_world, mstatus, ierr)
#endif
 
  end subroutine prg_recvparallel
 
  !
  ! Integer sum reduce
  !
  subroutine sumintparallel(sendBuf, recvBuf, icount)
 
    integer,intent(in) :: sendbuf(*)
    integer :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, mpi_int, &
         mpi_sum, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine sumintparallel
 
  !
  ! Real sum reduce
  !
  subroutine sumrealparallel(sendBuf, recvBuf, icount)
 
    real(dp),intent(in) :: sendbuf(*)
    real(dp),intent(out) :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, real_mpi_type, &
         mpi_sum, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine sumrealparallel
 
  !
  ! Integer max reduce
  !
  subroutine maxintparallel(sendBuf, recvBuf, icount)
 
    integer,intent(in) :: sendbuf(*)
    integer,intent(out) :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, mpi_int, &
         mpi_max, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine maxintparallel
 
  !
  ! Real max reduce
  !
  subroutine maxrealparallel(sendBuf, recvBuf, icount)
 
    real(dp),intent(in) :: sendbuf(*)
    real(dp),intent(out) :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, real_mpi_type, &
         mpi_max, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine maxrealparallel
 
  !
  ! Integer min reduce
  !
  subroutine minintparallel(sendBuf, recvBuf, icount)
 
    integer,intent(in) :: sendbuf(*)
    integer,intent(out) :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, mpi_int, &
         mpi_min, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine minintparallel
 
  !
  ! Real min reduce
  !
  subroutine minrealparallel(sendBuf, recvBuf, icount)
 
    real(dp),intent(in) :: sendbuf(*)
    real(dp),intent(out) :: recvbuf(*)
    integer,intent(in) :: icount
    integer :: i
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, real_mpi_type, &
         mpi_min, mpi_comm_world, ierr)
#else
    do i = 1, icount
      recvbuf(i) = sendbuf(i)
    enddo
#endif
 
  end subroutine minrealparallel
 
  !
  ! Real min reduce for 1 value
  !
  subroutine prg_minrealreduce(rvalue)
 
    real(dp),intent(inout) :: rvalue
    real(dp) :: slocal(1),sglobal(1)
 
    slocal(1) = rvalue
 
    call minrealparallel(slocal, sglobal, 1);
 
    rvalue = sglobal(1)
 
  end subroutine prg_minrealreduce
 
  !
  ! Real max reduce for 1 value
  !
  subroutine prg_maxrealreduce(rvalue)
 
    real(dp),intent(inout) :: rvalue
    real(dp) :: slocal(1), sglobal(1)
 
    slocal(1) = rvalue
 
    call maxrealparallel(slocal, sglobal, 1);
 
    rvalue = sglobal(1)
 
  end subroutine prg_maxrealreduce
 
  !
  ! Integer max reduce for 2 values
  !
  subroutine prg_maxintreduce2(value1, value2)
 
    integer,intent(inout) :: value1, value2
    integer :: slocal(2), sglobal(2)
 
    slocal(1) = value1
    slocal(2) = value2
 
    call maxintparallel(slocal, sglobal, 2);
 
    value1 = sglobal(1)
    value2 = sglobal(2)
 
  end subroutine prg_maxintreduce2
 
  !
  ! Integer sum reduce for 2 values
  !
  subroutine prg_sumintreduce2(value1, value2)
 
    integer,intent(inout) :: value1, value2
    integer :: slocal(2), sglobal(2)
 
    slocal(1) = value1
    slocal(2) = value2
 
    call sumintparallel(slocal, sglobal, 2);
 
    value1 = sglobal(1)
    value2 = sglobal(2)
 
  end subroutine prg_sumintreduce2
 
  !
  ! Real sum reduce for 1 value
  !
  subroutine prg_sumrealreduce(value1)
 
    real(dp),intent(inout) :: value1
    real(dp):: slocal(1), sglobal(1)
 
    slocal(1) = value1
 
    call sumrealparallel(slocal, sglobal, 1);
 
    value1 = sglobal(1)
 
  end subroutine prg_sumrealreduce
 
  !
  ! Real sum reduce for 2 values
  !
  subroutine prg_sumrealreduce2(value1, value2)
 
    real(dp),intent(inout) :: value1, value2
    real(dp):: slocal(2), sglobal(2)
 
    slocal(1) = value1
    slocal(2) = value2
 
    call sumrealparallel(slocal, sglobal, 2);
 
    value1 = sglobal(1)
    value2 = sglobal(2)
 
  end subroutine prg_sumrealreduce2
 
  !
  ! Real sum reduce for 3 values
  !
  subroutine prg_sumrealreduce3(value1, value2, value3)
 
    real(dp),intent(inout) :: value1, value2, value3
    real(dp):: slocal(3), sglobal(3)
 
    slocal(1) = value1
    slocal(2) = value2
    slocal(3) = value3
 
    call sumrealparallel(slocal, sglobal, 3);
 
    value1 = sglobal(1)
    value2 = sglobal(2)
    value3 = sglobal(3)
 
  end subroutine prg_sumrealreduce3
 
  !
  ! Real sum reduce for N values
  !
  subroutine prg_sumrealreducen(valueVec, N)
 
    real(dp),intent(inout) :: valuevec(n)
    integer, intent(in) :: n
 
    real(dp), allocatable :: sglobal(:)
 
    allocate(sglobal(n))
 
    call sumrealparallel(valuevec, sglobal, n);
 
    valuevec = sglobal
 
    deallocate(sglobal)
 
  end subroutine prg_sumrealreducen
 
 
  !
  ! Real sum reduce for Int values
  !
  subroutine prg_sumintreducen(valueVec, N)
 
    integer, intent(inout) :: valuevec(n)
    integer, intent(in) :: n
 
    integer, allocatable :: sglobal(:)
 
    allocate(sglobal(n))
 
    call sumintparallel(valuevec, sglobal, n);
 
    valuevec = sglobal
 
    deallocate(sglobal)
 
  end subroutine prg_sumintreducen
 
  !
  ! Wrapper for MPI_Allreduce real min with rank.
  !
  subroutine minrankrealparallel(sendBuf, recvBuf, icount)
 
    type(rankreducedata_t), intent(in) :: sendbuf(*)
    type(rankreducedata_t), intent(out) :: recvbuf(*)
    integer, intent(in) :: icount
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, mpi_double_int, &
         mpi_minloc, mpi_comm_world, ierr)
#else
    integer :: i
 
    do i = 1, icount
      recvbuf(i)%val = sendbuf(i)%val
      recvbuf(i)%rank = sendbuf(i)%rank
    enddo
#endif
 
  end subroutine minrankrealparallel
 
  !
  ! Wrapper for MPI_Allreduce real max with rank.
  !
  subroutine maxrankrealparallel(sendBuf, recvBuf, icount)
 
    type(rankreducedata_t), intent(in) :: sendbuf(*)
    type(rankreducedata_t), intent(out) :: recvbuf(*)
    integer, intent(in) :: icount
 
#ifdef DO_MPI
    call mpi_allreduce(sendbuf, recvbuf, icount, mpi_double_int, &
         mpi_maxloc, mpi_comm_world, ierr)
#else
    integer :: i
 
    do i = 1, icount
      recvbuf(i)%val = sendbuf(i)%val
      recvbuf(i)%rank = sendbuf(i)%rank
    enddo
#endif
 
  end subroutine maxrankrealparallel
 
  !
  ! Wrapper for MPI broadcast
  !
  subroutine prg_bcastparallel(buf, blen, root)
 
    character, intent(in) :: buf(*)
    integer, intent(in) :: blen, root
 
#ifdef DO_MPI
    call mpi_bcast(buf, blen, mpi_byte, root, mpi_comm_world, ierr)
#endif
 
  end subroutine prg_bcastparallel
 
  !
  ! Wrapper for real MPI_AllGather
  !
  subroutine allgatherrealparallel(sendBuf, sendLen, recvBuf, recvLen)
 
    real(dp), intent(in) :: sendbuf(*)
    real(dp), intent(out) :: recvbuf(*)
    integer, intent(in) :: sendlen, recvlen
 
#ifdef DO_MPI
    call mpi_allgather(sendbuf, sendlen, real_mpi_type, recvbuf, recvlen, &
         real_mpi_type, mpi_comm_world, ierr)
#endif
 
  end subroutine allgatherrealparallel
 
  !
  ! Wrapper for integer MPI_AllGather
  !
  subroutine allgatherintparallel(sendBuf, sendLen, recvBuf, recvLen)
 
    integer, intent(in) :: sendbuf(*)
    integer, intent(out) :: recvbuf(*)
    integer, intent(in) :: sendlen, recvlen
 
#ifdef DO_MPI
    call mpi_allgather(sendbuf, sendlen, mpi_int, recvbuf, recvlen, &
         mpi_int, mpi_comm_world, ierr)
#endif
 
  end subroutine allgatherintparallel
 
  !
  ! Wrapper for real MPI_AllGatherV
  !
  subroutine allgathervrealparallel(sendBuf, sendLen, recvBuf, recvLen, recvDispl)
 
    real(dp), intent(in) :: sendbuf(*)
    real(dp), intent(out) :: recvbuf(*)
    integer, intent(in) :: sendlen
    integer, intent(in) :: recvlen(*)
    integer, intent(in) :: recvdispl(*)
 
#ifdef DO_MPI
    call mpi_allgatherv(sendbuf, sendlen, real_mpi_type, recvbuf, &
         recvlen, recvdispl, real_mpi_type, &
         mpi_comm_world, ierr)
#endif
 
 
  end subroutine allgathervrealparallel
 
  !
  ! Wrapper for integer MPI_AllGatherV
  !
  subroutine allgathervintparallel(sendBuf, sendLen, recvBuf, recvLen, recvDispl)
 
    integer, intent(in) :: sendbuf(*)
    integer, intent(out) :: recvbuf(*)
    integer, intent(in) :: sendlen
    integer, intent(in) :: recvlen(*)
    integer, intent(in) :: recvdispl(*)
 
#ifdef DO_MPI
    call mpi_allgatherv(sendbuf, sendlen, mpi_int, recvbuf, recvlen, &
         recvdispl, mpi_int, mpi_comm_world, ierr)
#endif
 
  end subroutine allgathervintparallel
 
  !
  ! Wrapper for real MPI_AllReduce
  !
  subroutine prg_allsumrealreduceparallel(buf, buflen)
 
    real(dp), intent(inout) :: buf(*)
    integer, intent(in) :: buflen
 
#ifdef DO_MPI
    call mpi_allreduce(mpi_in_place, buf, buflen, real_mpi_type, &
         mpi_sum, mpi_comm_world, ierr)
#endif
 
  end subroutine prg_allsumrealreduceparallel
 
  !
  ! Wrapper for integer MPI_AllReduce
  !
  subroutine prg_allsumintreduceparallel(buf, buflen)
 
    integer, intent(inout) :: buf(*)
    integer, intent(in) :: buflen
 
#ifdef DO_MPI
    call mpi_allreduce(mpi_in_place, buf, buflen, mpi_int, &
         mpi_sum, mpi_comm_world, ierr)
#endif
 
  end subroutine prg_allsumintreduceparallel
 
  !
  ! Wrapper for bml_allGatherVParallel
  !
  subroutine prg_allgatherparallel(a)
 
    type (bml_matrix_t), intent(inout) :: a
 
#ifdef DO_MPI
    call bml_allgathervparallel(a)
#endif
 
  end subroutine prg_allgatherparallel
 
 
  !
  ! Wrapper for MPI_prg_wait
  !
  subroutine prg_wait()
 
    integer :: status(3)
    integer :: request, ierr
 
#ifdef DO_MPI
    !     call MPI_WAIT(request, status, ierr)
#endif
 
  end subroutine prg_wait
 
 
 
end module prg_parallel_mod