mpi.F90

Go to the documentation of this file.

!! Copyright (C) 2005-2006 Heiko Appel, Florian Lorenzen
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module mpi_oct_m
#ifdef HAVE_MPI
  use mpi_f08
#else
  use mpi_serial_stub_oct_m
#endif
  use blacs_oct_m
  use loct_oct_m
  use mpi_debug_oct_m
  use iso_c_binding
  use, intrinsic :: iso_fortran_env
#ifdef HAVE_OPENMP
  use omp_lib
#endif
 
 
  implicit none
 
  ! I do not make this module private on purpose, so that the symbols defined either in
  ! module mpi, or in mpif.h are exported
 
  type(MPI_Comm), parameter, public :: MPI_COMM_UNDEFINED = mpi_comm(-1)
 
  integer, parameter, private :: ROOT_PROCESS = 0
 
  type mpi_grp_t
    ! Components are public by default
    type(MPI_Comm) :: comm = mpi_comm_undefined 
    integer :: size = 0
    integer :: rank = 0
  contains
    ! Wrapper functions for common MPI calls
    ! We do not check the error code in any of those wrappers because the behavior of
    ! an application is undefined after an MPI error according to the standard. The
    ! default is to let the application crash in such a case with an error message
    ! from the MPI runtime.
    procedure :: barrier => mpi_grp_barrier
    procedure :: dmpi_grp_scatterv, zmpi_grp_scatterv, impi_grp_scatterv, lmpi_grp_scatterv
    generic :: scatterv => dmpi_grp_scatterv, zmpi_grp_scatterv, impi_grp_scatterv, lmpi_grp_scatterv
    procedure :: dmpi_grp_scatterv_i8, zmpi_grp_scatterv_i8, impi_grp_scatterv_i8, lmpi_grp_scatterv_i8
    generic :: scatterv => dmpi_grp_scatterv_i8, zmpi_grp_scatterv_i8, impi_grp_scatterv_i8, lmpi_grp_scatterv_i8
    procedure :: dmpi_grp_gatherv, zmpi_grp_gatherv, impi_grp_gatherv, lmpi_grp_gatherv
    generic :: gatherv => dmpi_grp_gatherv, zmpi_grp_gatherv, impi_grp_gatherv, lmpi_grp_gatherv
    procedure :: dmpi_grp_gather_0, zmpi_grp_gather_0, impi_grp_gather_0, lmpi_grp_gather_0
    generic :: gather => dmpi_grp_gather_0, zmpi_grp_gather_0, impi_grp_gather_0, lmpi_grp_gather_0
    procedure :: dmpi_grp_gatherv_i8, zmpi_grp_gatherv_i8, impi_grp_gatherv_i8, lmpi_grp_gatherv_i8
    generic :: gatherv => dmpi_grp_gatherv_i8, zmpi_grp_gatherv_i8, impi_grp_gatherv_i8, lmpi_grp_gatherv_i8
    procedure :: dmpi_grp_alltoallv, zmpi_grp_alltoallv, impi_grp_alltoallv, lmpi_grp_alltoallv
    generic :: alltoallv => dmpi_grp_alltoallv, zmpi_grp_alltoallv, impi_grp_alltoallv, lmpi_grp_alltoallv
    procedure :: dmpi_grp_alltoallv_2, zmpi_grp_alltoallv_2, impi_grp_alltoallv_2, lmpi_grp_alltoallv_2
    generic :: alltoallv => dmpi_grp_alltoallv_2, zmpi_grp_alltoallv_2, impi_grp_alltoallv_2, lmpi_grp_alltoallv_2
    procedure :: dmpi_grp_alltoallv_3, zmpi_grp_alltoallv_3, impi_grp_alltoallv_3, lmpi_grp_alltoallv_3
    generic :: alltoallv => dmpi_grp_alltoallv_3, zmpi_grp_alltoallv_3, impi_grp_alltoallv_3, lmpi_grp_alltoallv_3
    procedure :: dmpi_grp_alltoallv_i8, zmpi_grp_alltoallv_i8, impi_grp_alltoallv_i8, lmpi_grp_alltoallv_i8
    generic :: alltoallv => dmpi_grp_alltoallv_i8, zmpi_grp_alltoallv_i8, impi_grp_alltoallv_i8, lmpi_grp_alltoallv_i8
    procedure :: dmpi_grp_alltoall, zmpi_grp_alltoall, impi_grp_alltoall, lmpi_grp_alltoall
    generic :: alltoall => dmpi_grp_alltoall, zmpi_grp_alltoall, impi_grp_alltoall, lmpi_grp_alltoall
    procedure :: dmpi_grp_allgatherv, zmpi_grp_allgatherv, impi_grp_allgatherv, lmpi_grp_allgatherv
    generic :: allgatherv => dmpi_grp_allgatherv, zmpi_grp_allgatherv, impi_grp_allgatherv, lmpi_grp_allgatherv
    procedure :: dmpi_grp_allgatherv_2, zmpi_grp_allgatherv_2, impi_grp_allgatherv_2, lmpi_grp_allgatherv_2
    generic :: allgatherv => dmpi_grp_allgatherv_2, zmpi_grp_allgatherv_2, impi_grp_allgatherv_2, lmpi_grp_allgatherv_2
    procedure :: dmpi_grp_allgatherv_3, zmpi_grp_allgatherv_3, impi_grp_allgatherv_3, lmpi_grp_allgatherv_3
    generic :: allgatherv => dmpi_grp_allgatherv_3, zmpi_grp_allgatherv_3, impi_grp_allgatherv_3, lmpi_grp_allgatherv_3
    procedure :: dmpi_grp_allgatherv_3_1, zmpi_grp_allgatherv_3_1, impi_grp_allgatherv_3_1, lmpi_grp_allgatherv_3_1
    generic :: allgatherv => dmpi_grp_allgatherv_3_1, zmpi_grp_allgatherv_3_1, impi_grp_allgatherv_3_1, lmpi_grp_allgatherv_3_1
    procedure :: dmpi_grp_allgatherv_i8, zmpi_grp_allgatherv_i8, impi_grp_allgatherv_i8, lmpi_grp_allgatherv_i8
    generic :: allgatherv => dmpi_grp_allgatherv_i8, zmpi_grp_allgatherv_i8, impi_grp_allgatherv_i8, lmpi_grp_allgatherv_i8
    procedure :: dmpi_grp_allgatherv_inplace, zmpi_grp_allgatherv_inplace, &
      impi_grp_allgatherv_inplace, lmpi_grp_allgatherv_inplace
    generic :: allgatherv_inplace => dmpi_grp_allgatherv_inplace, zmpi_grp_allgatherv_inplace, &
      impi_grp_allgatherv_inplace, lmpi_grp_allgatherv_inplace
    procedure :: dmpi_grp_bcast, zmpi_grp_bcast, impi_grp_bcast, lmpi_grp_bcast
    generic :: bcast => dmpi_grp_bcast, zmpi_grp_bcast, impi_grp_bcast, lmpi_grp_bcast
    procedure :: dmpi_grp_bcast_0, zmpi_grp_bcast_0, impi_grp_bcast_0, lmpi_grp_bcast_0
    generic :: bcast => dmpi_grp_bcast_0, zmpi_grp_bcast_0, impi_grp_bcast_0, lmpi_grp_bcast_0
    procedure :: dmpi_grp_bcast_2, zmpi_grp_bcast_2, impi_grp_bcast_2, lmpi_grp_bcast_2
    generic :: bcast => dmpi_grp_bcast_2, zmpi_grp_bcast_2, impi_grp_bcast_2, lmpi_grp_bcast_2
    procedure :: dmpi_grp_bcast_3, zmpi_grp_bcast_3, impi_grp_bcast_3, lmpi_grp_bcast_3
    generic :: bcast => dmpi_grp_bcast_3, zmpi_grp_bcast_3, impi_grp_bcast_3, lmpi_grp_bcast_3
    procedure :: chmpi_grp_bcast_0, lompi_grp_bcast_0
    generic :: bcast => chmpi_grp_bcast_0, lompi_grp_bcast_0
    procedure :: dmpi_grp_bcast_0_l, zmpi_grp_bcast_0_l, impi_grp_bcast_0_l, lmpi_grp_bcast_0_l
    generic :: bcast => dmpi_grp_bcast_0_l, zmpi_grp_bcast_0_l, impi_grp_bcast_0_l, lmpi_grp_bcast_0_l
    procedure :: dmpi_grp_allreduce, zmpi_grp_allreduce, impi_grp_allreduce, lmpi_grp_allreduce
    generic :: allreduce => dmpi_grp_allreduce, zmpi_grp_allreduce, impi_grp_allreduce, lmpi_grp_allreduce
    procedure :: dmpi_grp_allreduce_2, zmpi_grp_allreduce_2, impi_grp_allreduce_2, lmpi_grp_allreduce_2
    generic :: allreduce => dmpi_grp_allreduce_2, zmpi_grp_allreduce_2, impi_grp_allreduce_2, lmpi_grp_allreduce_2
    procedure :: dmpi_grp_allreduce_3, zmpi_grp_allreduce_3, impi_grp_allreduce_3, lmpi_grp_allreduce_3
    generic :: allreduce => dmpi_grp_allreduce_3, zmpi_grp_allreduce_3, impi_grp_allreduce_3, lmpi_grp_allreduce_3
    procedure :: dmpi_grp_allreduce_0, zmpi_grp_allreduce_0, impi_grp_allreduce_0, lmpi_grp_allreduce_0
    generic :: allreduce => dmpi_grp_allreduce_0, zmpi_grp_allreduce_0, impi_grp_allreduce_0, lmpi_grp_allreduce_0
    procedure :: lompi_grp_allreduce_0
    generic :: allreduce => lompi_grp_allreduce_0
    procedure :: dmpi_grp_allreduce_inplace_0, zmpi_grp_allreduce_inplace_0
    procedure :: impi_grp_allreduce_inplace_0, lmpi_grp_allreduce_inplace_0
    procedure :: lompi_grp_allreduce_inplace_0
    generic :: allreduce_inplace => dmpi_grp_allreduce_inplace_0, zmpi_grp_allreduce_inplace_0
    generic :: allreduce_inplace => impi_grp_allreduce_inplace_0, lmpi_grp_allreduce_inplace_0
    generic :: allreduce_inplace => lompi_grp_allreduce_inplace_0
    procedure :: dmpi_grp_allreduce_inplace_1, zmpi_grp_allreduce_inplace_1, &
      impi_grp_allreduce_inplace_1, lmpi_grp_allreduce_inplace_1
    generic :: allreduce_inplace => dmpi_grp_allreduce_inplace_1, zmpi_grp_allreduce_inplace_1, &
      impi_grp_allreduce_inplace_1, lmpi_grp_allreduce_inplace_1
    procedure :: dmpi_grp_allreduce_inplace_2, zmpi_grp_allreduce_inplace_2, &
      impi_grp_allreduce_inplace_2, lmpi_grp_allreduce_inplace_2
    generic :: allreduce_inplace => dmpi_grp_allreduce_inplace_2, zmpi_grp_allreduce_inplace_2, &
      impi_grp_allreduce_inplace_2, lmpi_grp_allreduce_inplace_2
    procedure :: dmpi_grp_allgather, zmpi_grp_allgather, impi_grp_allgather, lmpi_grp_allgather
    generic :: allgather => dmpi_grp_allgather, zmpi_grp_allgather, impi_grp_allgather, lmpi_grp_allgather
    procedure :: dmpi_grp_allgather_0, zmpi_grp_allgather_0, impi_grp_allgather_0, lmpi_grp_allgather_0
    generic :: allgather => dmpi_grp_allgather_0, zmpi_grp_allgather_0, impi_grp_allgather_0, lmpi_grp_allgather_0
    procedure :: dmpi_grp_recv, zmpi_grp_recv, impi_grp_recv, lmpi_grp_recv
    generic :: recv => dmpi_grp_recv, zmpi_grp_recv, impi_grp_recv, lmpi_grp_recv
    procedure :: dmpi_grp_recv_0, zmpi_grp_recv_0, impi_grp_recv_0, lmpi_grp_recv_0
    generic :: recv => dmpi_grp_recv_0, zmpi_grp_recv_0, impi_grp_recv_0, lmpi_grp_recv_0
    procedure :: dmpi_grp_recv_2, zmpi_grp_recv_2, impi_grp_recv_2, lmpi_grp_recv_2
    generic :: recv => dmpi_grp_recv_2, zmpi_grp_recv_2, impi_grp_recv_2, lmpi_grp_recv_2
    procedure :: dmpi_grp_recv_3, zmpi_grp_recv_3, impi_grp_recv_3, lmpi_grp_recv_3
    generic :: recv => dmpi_grp_recv_3, zmpi_grp_recv_3, impi_grp_recv_3, lmpi_grp_recv_3
    procedure :: lompi_grp_recv_0
    generic :: recv => lompi_grp_recv_0
    procedure :: dmpi_grp_send, zmpi_grp_send, impi_grp_send, lmpi_grp_send
    generic :: send => dmpi_grp_send, zmpi_grp_send, impi_grp_send, lmpi_grp_send
    procedure :: dmpi_grp_send_0, zmpi_grp_send_0, impi_grp_send_0, lmpi_grp_send_0
    generic :: send => dmpi_grp_send_0, zmpi_grp_send_0, impi_grp_send_0, lmpi_grp_send_0
    procedure :: dmpi_grp_send_2, zmpi_grp_send_2, impi_grp_send_2, lmpi_grp_send_2
    generic :: send => dmpi_grp_send_2, zmpi_grp_send_2, impi_grp_send_2, lmpi_grp_send_2
    procedure :: dmpi_grp_send_3, zmpi_grp_send_3, impi_grp_send_3, lmpi_grp_send_3
    generic :: send => dmpi_grp_send_3, zmpi_grp_send_3, impi_grp_send_3, lmpi_grp_send_3
    procedure :: lompi_grp_send_0
    generic :: send => lompi_grp_send_0
    procedure :: dmpi_grp_irecv, zmpi_grp_irecv, impi_grp_irecv, lmpi_grp_irecv
    generic :: irecv => dmpi_grp_irecv, zmpi_grp_irecv, impi_grp_irecv, lmpi_grp_irecv
    procedure :: dmpi_grp_irecv_0, zmpi_grp_irecv_0, impi_grp_irecv_0, lmpi_grp_irecv_0
    generic :: irecv => dmpi_grp_irecv_0, zmpi_grp_irecv_0, impi_grp_irecv_0, lmpi_grp_irecv_0
    procedure :: dmpi_grp_irecv_2, zmpi_grp_irecv_2, impi_grp_irecv_2, lmpi_grp_irecv_2
    generic :: irecv => dmpi_grp_irecv_2, zmpi_grp_irecv_2, impi_grp_irecv_2, lmpi_grp_irecv_2
    procedure :: dmpi_grp_irecv_3, zmpi_grp_irecv_3, impi_grp_irecv_3, lmpi_grp_irecv_3
    generic :: irecv => dmpi_grp_irecv_3, zmpi_grp_irecv_3, impi_grp_irecv_3, lmpi_grp_irecv_3
    procedure :: dmpi_grp_irecv_0_int64, zmpi_grp_irecv_0_int64, impi_grp_irecv_0_int64, lmpi_grp_irecv_0_int64
    generic :: irecv => dmpi_grp_irecv_0_int64, zmpi_grp_irecv_0_int64, impi_grp_irecv_0_int64, lmpi_grp_irecv_0_int64
    procedure :: dmpi_grp_isend, zmpi_grp_isend, impi_grp_isend, lmpi_grp_isend
    generic :: isend => dmpi_grp_isend, zmpi_grp_isend, impi_grp_isend, lmpi_grp_isend
    procedure :: dmpi_grp_isend_0, zmpi_grp_isend_0, impi_grp_isend_0, lmpi_grp_isend_0
    generic :: isend => dmpi_grp_isend_0, zmpi_grp_isend_0, impi_grp_isend_0, lmpi_grp_isend_0
    procedure :: dmpi_grp_isend_2, zmpi_grp_isend_2, impi_grp_isend_2, lmpi_grp_isend_2
    generic :: isend => dmpi_grp_isend_2, zmpi_grp_isend_2, impi_grp_isend_2, lmpi_grp_isend_2
    procedure :: dmpi_grp_isend_3, zmpi_grp_isend_3, impi_grp_isend_3, lmpi_grp_isend_3
    generic :: isend => dmpi_grp_isend_3, zmpi_grp_isend_3, impi_grp_isend_3, lmpi_grp_isend_3
    procedure :: dmpi_grp_isend_0_int64, zmpi_grp_isend_0_int64, impi_grp_isend_0_int64, lmpi_grp_isend_0_int64
    generic :: isend => dmpi_grp_isend_0_int64, zmpi_grp_isend_0_int64, impi_grp_isend_0_int64, lmpi_grp_isend_0_int64
    procedure :: mpi_grp_wait, mpi_grp_waitall
    generic :: wait => mpi_grp_wait, mpi_grp_waitall
    procedure :: abort => mpi_grp_abort
    procedure :: is_root => mpi_grp_is_root
  end type mpi_grp_t
 
  type(mpi_grp_t), public :: mpi_world
 
  private  :: not_in_openmp
  public   :: mpi_get_wtime
 
  abstract interface
    function omp_region_func()
      logical :: omp_region_func
    end function
  end interface
 
#if defined(HAVE_MPI) && defined(HAVE_OPENMP)
 
  integer, parameter :: octopus_mpi_thread_level = mpi_thread_funneled
  procedure(omp_region_func), pointer :: mpi_call_is_thread_safe => mpi_call_is_thread_funneled_safe
#elif defined(HAVE_MPI)
 
  integer, parameter :: octopus_mpi_thread_level = mpi_thread_single
  procedure(omp_region_func), pointer :: mpi_call_is_thread_safe => not_in_openmp
#else
 
  procedure(omp_region_func), pointer :: mpi_call_is_thread_safe => not_in_openmp
#endif
 
 
contains
 
  subroutine mpi_init_comm(comm)
    type(mpi_comm), intent(out) :: comm
#if defined(HAVE_MPI)
#if defined(HAVE_OPENMP)
    integer :: provided
 
    call mpi_init_thread(octopus_mpi_thread_level, provided)
    call check_threading_support(comm)
#else
    call mpi_init()
#endif
    comm = mpi_comm_world
#else
    comm = mpi_comm_undefined
#endif
 
  end subroutine mpi_init_comm
 
 
  subroutine check_threading_support(comm)
    type(mpi_comm), intent(in) :: comm
 
#if defined(HAVE_MPI) && defined(HAVE_OPENMP)
    integer :: provided, ierr, rank
 
    call mpi_query_thread(provided)
    if (provided < octopus_mpi_thread_level) then
      call mpi_comm_rank(comm, rank)
      if (rank == 0) write(*, '(a)') 'MPI library threading support is less than required by Octopus'
      call mpi_abort(comm, 1, ierr)
    end if
#else
    return
#endif
 
  end subroutine check_threading_support
 
 
  subroutine blacs_init()
#if defined(HAVE_MPI)
#ifdef HAVE_SCALAPACK
    integer :: iam, nprocs
    integer :: blacs_default_system_context
 
    ! Determine my process number and the number of processes in machine
    call blacs_pinfo(iam, nprocs)
 
    ! If machine needs additional set up, do it now
    if (nprocs < 1) then
      call blacs_setup(iam, mpi_world%size)
    end if
 
    ! blacs_gridinit() or blacs_gridmap() must be called, else
    ! blacs_exit() triggers an error with openmpi:
    ! *** An error occurred in MPI_Type_free
    ! *** MPI_ERR_TYPE: invalid datatype
    call blacs_get(0, 0, blacs_default_system_context)
    call blacs_gridinit(blacs_default_system_context, 'R', mpi_world%size, 1)
    call blacs_gridexit(blacs_default_system_context)
#endif
#endif
  end subroutine blacs_init
 
 
  subroutine mpi_mod_end()
 
#ifdef HAVE_SCALAPACK
    if (mpi_world%comm /= mpi_comm_undefined) call blacs_exit(1)
#endif
 
    nullify(mpi_call_is_thread_safe)
 
#if defined(HAVE_MPI)
    if (mpi_world%comm /= mpi_comm_undefined) call mpi_finalize()
#endif
 
  end subroutine mpi_mod_end
 
 
  subroutine mpi_grp_init(grp, comm)
    type(mpi_grp_t), intent(out)  :: grp
    type(mpi_comm),  intent(in)   :: comm
 
    grp%comm = comm
#if defined(HAVE_MPI)
    if (grp%comm == mpi_comm_null) grp%comm = mpi_comm_undefined
#endif
 
    if (grp%comm == mpi_comm_undefined) then
      grp%rank = 0
      grp%size = 1
#if defined(HAVE_MPI)
    else
      call mpi_comm_rank(grp%comm, grp%rank)
 
      call mpi_comm_size(grp%comm, grp%size)
#endif
    end if
 
  end subroutine mpi_grp_init
 
 
  logical &
#ifndef HAVE_OPENMP
    pure &
#endif
    function not_in_openmp()
 
#ifdef HAVE_OPENMP
    not_in_openmp = .not. omp_in_parallel()
#else
    not_in_openmp = .true.
#endif
 
  end function not_in_openmp
 
 
#if defined(HAVE_MPI) && defined(HAVE_OPENMP)
  logical function mpi_call_is_thread_funneled_safe()
    mpi_call_is_thread_funneled_safe = &
      not_in_openmp() .or. (omp_get_thread_num() == 0)
  end function mpi_call_is_thread_funneled_safe
#endif
 
 
  subroutine mpi_grp_copy(mpi_grp_out, mpi_grp_in)
    type(mpi_grp_t), intent(out) :: mpi_grp_out
    type(mpi_grp_t), intent(in)  :: mpi_grp_in
 
    mpi_grp_out%comm = mpi_grp_in%comm
    mpi_grp_out%size = mpi_grp_in%size
    mpi_grp_out%rank = mpi_grp_in%rank
  end subroutine mpi_grp_copy
 
  ! ---------------------------------------------------------
  subroutine mpi_grp_duplicate(mpi_grp_out, mpi_grp_in)
    type(mpi_grp_t), intent(out) :: mpi_grp_out
    type(mpi_grp_t), intent(in)  :: mpi_grp_in
 
#if defined(HAVE_MPI)
    call mpi_comm_dup(mpi_grp_in%comm, mpi_grp_out%comm)
    call mpi_comm_rank(mpi_grp_out%comm, mpi_grp_out%rank)
    call mpi_comm_size(mpi_grp_out%comm, mpi_grp_out%size)
#else
    call mpi_grp_copy(mpi_grp_out, mpi_grp_in)
#endif
  end subroutine mpi_grp_duplicate
 
  logical function mpi_grp_is_root(grp)
    class(mpi_grp_t), intent(in) :: grp
 
    mpi_grp_is_root = (grp%rank == root_process)
  end function mpi_grp_is_root
 
  ! ---------------------------------------------------------
  subroutine mpi_grp_barrier(mpi_grp)
    class(mpi_grp_t), intent(in) :: mpi_grp
 
    if (mpi_grp%comm == mpi_comm_undefined) return
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_barrier)
    call mpi_barrier(mpi_grp%comm)
    call mpi_debug_out(mpi_grp%comm, c_mpi_barrier)
#endif
  end subroutine mpi_grp_barrier
 
  ! ---------------------------------------------------------
  subroutine chmpi_grp_bcast_0(mpi_grp, buf, cnt, sendtype, root)
    class(mpi_grp_t), intent(in)    :: mpi_grp
    character(len=*), intent(inout) :: buf
    integer,          intent(in)    :: cnt
    type(mpi_datatype), intent(in)  :: sendtype
    integer,          intent(in)    :: root
 
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_bcast)
    if (mpi_grp%comm /= mpi_comm_undefined) then
      call mpi_bcast(buf, cnt, sendtype, root, mpi_grp%comm)
    end if
    call mpi_debug_out(mpi_grp%comm, c_mpi_bcast)
#endif
  end subroutine chmpi_grp_bcast_0
 
  ! ---------------------------------------------------------
  subroutine lompi_grp_bcast_0(mpi_grp, buf, cnt, sendtype, root)
    class(mpi_grp_t), intent(in)    :: mpi_grp
    logical,          intent(inout) :: buf
    integer,          intent(in)    :: cnt
    type(mpi_datatype), intent(in)  :: sendtype
    integer,          intent(in)    :: root
 
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_bcast)
    if (mpi_grp%comm /= mpi_comm_undefined) then
      call mpi_bcast(buf, cnt, sendtype, root, mpi_grp%comm)
    end if
    call mpi_debug_out(mpi_grp%comm, c_mpi_bcast)
#endif
  end subroutine lompi_grp_bcast_0
 
  ! ---------------------------------------------------------
  ! copy routine for serial case
  subroutine lompi_grp_copy_0(sendbuf, recvbuf, count)
    use iso_c_binding
    logical, target,  intent(in)  :: sendbuf
    logical, target,  intent(out) :: recvbuf
    integer,          intent(in)  :: count
    integer :: ii
    logical, pointer :: send(:), recv(:)
 
    call c_f_pointer(c_loc(sendbuf), send, [count])
    call c_f_pointer(c_loc(recvbuf), recv, [count])
    do ii = 1, count
      recv(ii) = send(ii)
    end do
  end subroutine lompi_grp_copy_0
 
  ! ---------------------------------------------------------
  subroutine lompi_grp_allreduce_0(mpi_grp, sendbuf, recvbuf, count, datatype, op)
    class(mpi_grp_t), intent(in)  :: mpi_grp
    logical,          intent(in)  :: sendbuf
    logical,          intent(out) :: recvbuf
    integer,          intent(in)  :: count
    type(mpi_datatype), intent(in):: datatype
    type(mpi_op),     intent(in)  :: op
 
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_allreduce)
    if (mpi_grp%comm /= mpi_comm_undefined) then
      call mpi_allreduce(sendbuf, recvbuf, count, datatype, op, &
        mpi_grp%comm)
    else
      call lompi_grp_copy_0(sendbuf, recvbuf, count)
    end if
    call mpi_debug_out(mpi_grp%comm, c_mpi_allreduce)
#else
    call lompi_grp_copy_0(sendbuf, recvbuf, count)
#endif
  end subroutine lompi_grp_allreduce_0
 
  ! ---------------------------------------------------------
  subroutine lompi_grp_allreduce_inplace_0(mpi_grp, recvbuf, count, datatype, op)
    class(mpi_grp_t), intent(in)    :: mpi_grp
    logical,          intent(inout) :: recvbuf
    integer,          intent(in)    :: count
    type(mpi_datatype), intent(in)  :: datatype
    type(mpi_op),     intent(in)    :: op
 
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_allreduce)
    if (mpi_grp%comm /= mpi_comm_undefined) then
      call mpi_allreduce(mpi_in_place, recvbuf, count, datatype, op, &
        mpi_grp%comm)
    end if
    call mpi_debug_out(mpi_grp%comm, c_mpi_allreduce)
#endif
  end subroutine lompi_grp_allreduce_inplace_0
 
  ! ---------------------------------------------------------
  subroutine lompi_grp_recv_0(mpi_grp, recvbuf, recvcount, recvtype, source, tag)
    class(mpi_grp_t),  intent(in)  :: mpi_grp
    logical,           intent(out) :: recvbuf
    integer,           intent(in)  :: recvcount
    type(mpi_datatype),intent(in)  :: recvtype
    integer,           intent(in)  :: source
    integer, optional, intent(in)  :: tag
 
    integer :: tag_
 
    tag_ = 0
    if (present(tag)) tag_ = tag
    if (mpi_grp%comm == mpi_comm_undefined) return
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_recv)
    call mpi_recv(recvbuf, recvcount, recvtype, source, tag_, mpi_grp%comm, mpi_status_ignore)
    call mpi_debug_out(mpi_grp%comm, c_mpi_recv)
#endif
  end subroutine lompi_grp_recv_0
 
  ! ---------------------------------------------------------
  subroutine lompi_grp_send_0(mpi_grp, sendbuf, sendcount, sendtype, dest, tag)
    class(mpi_grp_t),  intent(in)  :: mpi_grp
    logical,           intent(in)  :: sendbuf
    integer,           intent(in)  :: sendcount
    type(mpi_datatype),intent(in)  :: sendtype
    integer,           intent(in)  :: dest
    integer, optional, intent(in)  :: tag
 
    integer :: tag_
 
    tag_ = 0
    if (present(tag)) tag_ = tag
    if (mpi_grp%comm == mpi_comm_undefined) return
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_send)
    call mpi_send(sendbuf, sendcount, sendtype, dest, tag_, mpi_grp%comm)
    call mpi_debug_out(mpi_grp%comm, c_mpi_send)
#endif
  end subroutine lompi_grp_send_0
 
  ! ---------------------------------------------------------
  subroutine mpi_grp_wait(mpi_grp, request)
    class(mpi_grp_t),  intent(in)    :: mpi_grp
    type(mpi_request), intent(inout) :: request
 
    if (mpi_grp%comm == mpi_comm_undefined) return
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_wait)
    call mpi_wait(request, mpi_status_ignore)
    call mpi_debug_out(mpi_grp%comm, c_mpi_wait)
#endif
  end subroutine mpi_grp_wait
 
  ! ---------------------------------------------------------
  subroutine mpi_grp_waitall(mpi_grp, count, requests)
    class(mpi_grp_t),  intent(in)    :: mpi_grp
    integer,           intent(in)    :: count
    type(mpi_request), intent(inout) :: requests(:)
 
    if (mpi_grp%comm == mpi_comm_undefined) return
#if defined(HAVE_MPI)
    assert(mpi_call_is_thread_safe())
 
    call mpi_debug_in(mpi_grp%comm, c_mpi_waitall)
    call mpi_waitall(count, requests, mpi_statuses_ignore)
    call mpi_debug_out(mpi_grp%comm, c_mpi_waitall)
#endif
  end subroutine mpi_grp_waitall
 
  ! ---------------------------------------------------------
  subroutine mpi_grp_abort(mpi_grp)
    class(mpi_grp_t),  intent(in)    :: mpi_grp
 
    if (mpi_grp%comm /= mpi_comm_undefined) then
#if defined(HAVE_MPI)
      assert(mpi_call_is_thread_safe())
 
      ! Abort with an arbitrary error code
      call mpi_abort(mpi_grp%comm, 999)
#endif
    end if
 
    error stop 1
 
  end subroutine mpi_grp_abort
 
  ! ---------------------------------------------------------
  real(real64) function mpi_get_wtime() result(now)
#if defined(HAVE_MPI)
    now = mpi_wtime()
#else
    now = loct_clock()
#endif
  end function mpi_get_wtime
 
#include "undef.F90"
#include "real.F90"
#include "mpi_inc.F90"
 
#include "undef.F90"
#include "complex.F90"
#include "mpi_inc.F90"
 
#include "undef.F90"
#include "integer.F90"
#include "mpi_inc.F90"
 
#include "undef.F90"
#include "integer8.F90"
#include "mpi_inc.F90"
 
end module mpi_oct_m
 
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: