hecmw_comm_f.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
 
module m_hecmw_comm_f
contains
 
  !C
  !C***
  !C*** hecmw_barrier
  !C***
  !C
  subroutine hecmw_barrier (hecMESH)
    use hecmw_util
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_barrier (hecmesh%MPI_COMM, ierr)
#endif
  end subroutine hecmw_barrier
 
  subroutine hecmw_scatterv_dp(sbuf, sc, disp, rbuf, rc, root, comm)
    use hecmw_util
    implicit none
    double precision   :: sbuf(*) !send buffer
    integer(kind=kint) :: sc(*)   !send counts
    integer(kind=kint) :: disp(*) !displacement
    double precision   :: rbuf(*) !receive buffer
    integer(kind=kint) :: rc      !receive counts
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_scatterv( sbuf, sc, disp, mpi_double_precision, &
      rbuf, rc, mpi_double_precision, &
      root, comm, ierr )
#else
    rbuf(1) = sbuf(1)
#endif
  end subroutine hecmw_scatterv_dp
 
#ifndef HECMW_SERIAL
  function hecmw_operation_hec2mpi(operation)
    use hecmw_util
    implicit none
    integer(kind=kint) :: hecmw_operation_hec2mpi
    integer(kind=kint) :: operation
    hecmw_operation_hec2mpi = -1
    if (operation == hecmw_sum) then
      hecmw_operation_hec2mpi = mpi_sum
    elseif (operation == hecmw_prod) then
      hecmw_operation_hec2mpi = mpi_prod
    elseif (operation == hecmw_max) then
      hecmw_operation_hec2mpi = mpi_max
    elseif (operation == hecmw_min) then
      hecmw_operation_hec2mpi = mpi_min
    endif
  end function hecmw_operation_hec2mpi
#endif
 
  subroutine hecmw_scatter_int_1(sbuf, rval, root, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*) !send buffer
    integer(kind=kint) :: rval !receive value
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_scatter( sbuf, 1, mpi_integer, &
      &     rval, 1, mpi_integer, root, comm, ierr )
#else
    rval=sbuf(1)
#endif
  end subroutine hecmw_scatter_int_1
 
  subroutine hecmw_gather_int_1(sval, rbuf, root, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sval !send buffer
    integer(kind=kint) :: rbuf(*) !receive buffer
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_gather( sval, 1, mpi_integer, &
      &     rbuf, 1, mpi_integer, root, comm, ierr )
#else
    rbuf(1)=sval
#endif
  end subroutine hecmw_gather_int_1
 
  subroutine hecmw_allgather_int_1(sval, rbuf, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sval !send buffer
    integer(kind=kint) :: rbuf(*) !receive buffer
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_allgather( sval, 1, mpi_integer, &
      &     rbuf, 1, mpi_integer, comm, ierr )
#else
    rbuf(1)=sval
#endif
  end subroutine hecmw_allgather_int_1
 
  subroutine hecmw_scatterv_real(sbuf, scs, disp, &
      &     rbuf, rc, root, comm)
    use hecmw_util
    implicit none
    real(kind=kreal)   :: sbuf(*) !send buffer
    integer(kind=kint) :: scs(*) !send counts
    integer(kind=kint) :: disp(*) !displacement
    real(kind=kreal)   :: rbuf(*) !receive buffer
    integer(kind=kint) :: rc  !receive counts
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_scatterv( sbuf, scs, disp, mpi_real8, &
      &     rbuf, rc, mpi_real8, root, comm, ierr )
#else
    rbuf(1:rc)=sbuf(1:rc)
#endif
  end subroutine hecmw_scatterv_real
 
  subroutine hecmw_gatherv_real(sbuf, sc, &
      &     rbuf, rcs, disp, root, comm)
    use hecmw_util
    implicit none
    real(kind=kreal)   :: sbuf(*) !send buffer
    integer(kind=kint) :: sc  !send counts
    real(kind=kreal)   :: rbuf(*) !receive buffer
    integer(kind=kint) :: rcs(*) !receive counts
    integer(kind=kint) :: disp(*) !displacement
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_gatherv( sbuf, sc, mpi_real8, &
      &     rbuf, rcs, disp, mpi_real8, root, comm, ierr )
#else
    rbuf(1:sc)=sbuf(1:sc)
#endif
  end subroutine hecmw_gatherv_real
 
  subroutine hecmw_gatherv_int(sbuf, sc, &
      &     rbuf, rcs, disp, root, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*) !send buffer
    integer(kind=kint) :: sc  !send counts
    integer(kind=kint) :: rbuf(*) !receive buffer
    integer(kind=kint) :: rcs(*) !receive counts
    integer(kind=kint) :: disp(*) !displacement
    integer(kind=kint) :: root
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_gatherv( sbuf, sc, mpi_integer, &
      &     rbuf, rcs, disp, mpi_integer, root, comm, ierr )
#else
    rbuf(1:sc)=sbuf(1:sc)
#endif
  end subroutine hecmw_gatherv_int
 
  subroutine hecmw_allreduce_int_1(sval, rval, op, comm)
    use hecmw_util
    implicit none
    integer(kind=kint)   :: sval !send val
    integer(kind=kint)   :: rval !receive val
    integer(kind=kint):: op, comm, ierr
#ifndef HECMW_SERIAL
    call mpi_allreduce(sval, rval, 1, mpi_integer, &
      &     hecmw_operation_hec2mpi(op), comm, ierr)
#else
    rval=sval
#endif
  end subroutine hecmw_allreduce_int_1
 
  subroutine hecmw_alltoall_int(sbuf, sc, rbuf, rc, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*)
    integer(kind=kint) :: sc
    integer(kind=kint) :: rbuf(*)
    integer(kind=kint) :: rc
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_alltoall( sbuf, sc, mpi_integer, &
      &     rbuf, rc, mpi_integer, comm, ierr )
#else
    rbuf(1:sc)=sbuf(1:sc)
#endif
  end subroutine hecmw_alltoall_int
 
  subroutine hecmw_allgatherv_int(sbuf, sc, rbuf, rcs, disp, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*) !send buffer
    integer(kind=kint) :: sc      !send count
    integer(kind=kint) :: rbuf(*) !receive buffer
    integer(kind=kint) :: rcs(*)  !receive counts
    integer(kind=kint) :: disp(*) !displacements
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_allgatherv( sbuf, sc, mpi_integer, &
      &     rbuf, rcs, disp, mpi_integer, comm, ierr )
#else
    rbuf(disp(1)+1:disp(1)+sc) = sbuf(1:sc)
#endif
  end subroutine hecmw_allgatherv_int
 
  subroutine hecmw_allgatherv_real(sbuf, sc, rbuf, rcs, disp, comm)
    use hecmw_util
    implicit none
    real(kind=kreal)   :: sbuf(*) !send buffer
    integer(kind=kint) :: sc      !send count
    real(kind=kreal)   :: rbuf(*) !receive buffer
    integer(kind=kint) :: rcs(*)  !receive counts
    integer(kind=kint) :: disp(*) !displacements
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_allgatherv( sbuf, sc, mpi_real8, &
      &     rbuf, rcs, disp, mpi_real8, comm, ierr )
#else
    rbuf(disp(1)+1:disp(1)+sc) = sbuf(1:sc)
#endif
  end subroutine hecmw_allgatherv_real
 
  subroutine hecmw_alltoallv_int(sbuf, scs, sdisp, rbuf, rcs, rdisp, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*)  !send buffer
    integer(kind=kint) :: scs(*)   !send counts
    integer(kind=kint) :: sdisp(*) !send displacements
    integer(kind=kint) :: rbuf(*)  !receive buffer
    integer(kind=kint) :: rcs(*)   !receive counts
    integer(kind=kint) :: rdisp(*) !receive displacements
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_alltoallv( sbuf, scs, sdisp, mpi_integer, &
      &     rbuf, rcs, rdisp, mpi_integer, comm, ierr )
#else
    rbuf(rdisp(1)+1:rdisp(1)+rcs(1)) = sbuf(sdisp(1)+1:sdisp(1)+scs(1))
#endif
  end subroutine hecmw_alltoallv_int
 
  subroutine hecmw_alltoallv_real(sbuf, scs, sdisp, rbuf, rcs, rdisp, comm)
    use hecmw_util
    implicit none
    real(kind=kreal)   :: sbuf(*)  !send buffer
    integer(kind=kint) :: scs(*)   !send counts
    integer(kind=kint) :: sdisp(*) !send displacements
    real(kind=kreal)   :: rbuf(*)  !receive buffer
    integer(kind=kint) :: rcs(*)   !receive counts
    integer(kind=kint) :: rdisp(*) !receive displacements
    integer(kind=kint) :: comm
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_alltoallv( sbuf, scs, sdisp, mpi_real8, &
      &     rbuf, rcs, rdisp, mpi_real8, comm, ierr )
#else
    rbuf(rdisp(1)+1:rdisp(1)+rcs(1)) = sbuf(sdisp(1)+1:sdisp(1)+scs(1))
#endif
  end subroutine hecmw_alltoallv_real
 
  subroutine hecmw_allreduce_i_comm(val, n, ntag, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: n, ntag, comm
    integer(kind=kint) :: val(*)
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    ! VALM is an automatic (host) array on purpose: an allocatable would land in
    ! managed memory under -gpu=mem:managed, making MPI_allreduce src=host/dst=managed
    ! -- CUDA-aware MPI (HPC-X UCC) rejects asymmetric src/dst memory types.
    integer(kind=kint) :: VALM(n)
    valm = 0
    if (ntag .eq. hecmw_sum) call mpi_allreduce(val, valm, n, mpi_integer, mpi_sum, comm, ierr)
    if (ntag .eq. hecmw_max) call mpi_allreduce(val, valm, n, mpi_integer, mpi_max, comm, ierr)
    if (ntag .eq. hecmw_min) call mpi_allreduce(val, valm, n, mpi_integer, mpi_min, comm, ierr)
    val(1:n) = valm(1:n)
#endif
  end subroutine hecmw_allreduce_i_comm
 
  subroutine hecmw_allreduce_r_comm(val, n, ntag, comm)
    use hecmw_util
    implicit none
    integer(kind=kint) :: n, ntag, comm
    real(kind=kreal) :: val(*)
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    ! VALM automatic (host) -- see hecmw_allreduce_I_comm: an allocatable would be
    ! managed under -gpu=mem:managed and trip the CUDA-aware MPI asymmetric-memtype error.
    real(kind=kreal) :: valm(n)
    valm = 0.d0
    if (ntag .eq. hecmw_sum) call mpi_allreduce(val, valm, n, mpi_double_precision, mpi_sum, comm, ierr)
    if (ntag .eq. hecmw_max) call mpi_allreduce(val, valm, n, mpi_double_precision, mpi_max, comm, ierr)
    if (ntag .eq. hecmw_min) call mpi_allreduce(val, valm, n, mpi_double_precision, mpi_min, comm, ierr)
    val(1:n) = valm(1:n)
#endif
  end subroutine hecmw_allreduce_r_comm
 
  subroutine hecmw_comm_size(comm, isize)
    use hecmw_util
    implicit none
    integer(kind=kint) :: comm, isize
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_comm_size(comm, isize, ierr)
#else
    isize = 1
#endif
  end subroutine hecmw_comm_size
 
  subroutine hecmw_isend_int(sbuf, sc, dest, &
      &     tag, comm, req)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sbuf(*)
    integer(kind=kint) :: sc
    integer(kind=kint) :: dest
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: req
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_isend(sbuf, sc, mpi_integer, &
      &     dest, tag, comm, req, ierr)
#endif
  end subroutine hecmw_isend_int
 
  subroutine hecmw_isend_r(sbuf, sc, dest, &
      &     tag, comm, req)
    use hecmw_util
    implicit none
    integer(kind=kint) :: sc
    double precision, dimension(sc) :: sbuf
    integer(kind=kint) :: dest
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: req
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_isend(sbuf, sc, mpi_double_precision, &
      &     dest, tag, comm, req, ierr)
#endif
  end subroutine hecmw_isend_r
 
  subroutine hecmw_irecv_int(rbuf, rc, source, &
      &     tag, comm, req)
    use hecmw_util
    implicit none
    integer(kind=kint) :: rbuf(*)
    integer(kind=kint) :: rc
    integer(kind=kint) :: source
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: req
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_irecv(rbuf, rc, mpi_integer, &
      &     source, tag, comm, req, ierr)
#endif
  end subroutine hecmw_irecv_int
 
  subroutine hecmw_irecv_r(rbuf, rc, source, &
      &     tag, comm, req)
    use hecmw_util
    implicit none
    integer(kind=kint) :: rc
    double precision, dimension(rc) :: rbuf
    integer(kind=kint) :: source
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: req
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_irecv(rbuf, rc, mpi_double_precision, &
      &     source, tag, comm, req, ierr)
#endif
  end subroutine hecmw_irecv_r
 
  subroutine hecmw_waitall(cnt, reqs, stats)
    use hecmw_util
    implicit none
    integer(kind=kint) :: cnt
    integer(kind=kint) :: reqs(*)
    integer(kind=kint) :: stats(HECMW_STATUS_SIZE,*)
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_waitall(cnt, reqs, stats, ierr)
#endif
  end subroutine hecmw_waitall
 
  subroutine hecmw_recv_int(rbuf, rc, source, &
      &     tag, comm, stat)
    use hecmw_util
    implicit none
    integer(kind=kint) :: rbuf(*)
    integer(kind=kint) :: rc
    integer(kind=kint) :: source
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: stat(HECMW_STATUS_SIZE)
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_recv(rbuf, rc, mpi_integer, &
      &     source, tag, comm, stat, ierr)
#endif
  end subroutine hecmw_recv_int
 
  subroutine hecmw_recv_r(rbuf, rc, source, &
      &     tag, comm, stat)
    use hecmw_util
    implicit none
    integer(kind=kint) :: rc
    double precision, dimension(rc) :: rbuf
    integer(kind=kint) :: source
    integer(kind=kint) :: tag
    integer(kind=kint) :: comm
    integer(kind=kint) :: stat(HECMW_STATUS_SIZE)
#ifndef HECMW_SERIAL
    integer(kind=kint) :: ierr
    call mpi_recv(rbuf, rc, mpi_double_precision, &
      &     source, tag, comm, stat, ierr)
#endif
  end subroutine hecmw_recv_r
  !C
  !C***
  !C*** hecmw_allREDUCE
  !C***
  !C
  subroutine hecmw_allreduce_dp(val,VALM,n,hec_op,comm )
    use hecmw_util
    implicit none
    integer(kind=kint) :: n, hec_op,op, comm, ierr
    double precision, dimension(n) :: val
    double precision, dimension(n) :: VALM
#ifndef HECMW_SERIAL
    select case( hec_op )
      case ( hecmw_sum )
        op = mpi_sum
      case ( hecmw_prod )
        op = mpi_prod
      case ( hecmw_max )
        op = mpi_max
      case ( hecmw_min )
        op = mpi_min
    end select
    call mpi_allreduce(val,valm,n,mpi_double_precision,op,comm,ierr)
#else
    integer(kind=kint) :: i
    do i=1,n
      valm(i) = val(i)
    end do
#endif
  end subroutine hecmw_allreduce_dp
 
  subroutine hecmw_allreduce_dp1(s1,s2,hec_op,comm )
    use hecmw_util
    implicit none
    integer(kind=kint) ::  hec_op, comm
    double precision :: s1, s2
    double precision, dimension(1) :: val
    double precision, dimension(1) :: VALM
#ifndef HECMW_SERIAL
    val(1) = s1
    valm(1) = s2
    call hecmw_allreduce_dp(val,valm,1,hec_op,comm )
    s1 = val(1)
    s2 = valm(1)
#else
    s2 = s1
#endif
  end subroutine hecmw_allreduce_dp1
  !C
  !C***
  !C*** hecmw_allREDUCE_R
  !C***
  !C
  subroutine hecmw_allreduce_r (hecMESH, val, n, ntag)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, ntag
    real(kind=kreal), dimension(n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    real(kind=kreal), dimension(:), allocatable :: valm, sbuf
 
    allocate (valm(n), sbuf(n))
    sbuf= val
    valm= 0.d0
    if (ntag .eq. hecmw_sum) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_double_precision, mpi_sum,             &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    if (ntag .eq. hecmw_max) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_double_precision, mpi_max,             &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    if (ntag .eq. hecmw_min) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_double_precision, mpi_min,             &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    val= valm
    deallocate (valm, sbuf)
#endif
  end subroutine hecmw_allreduce_r
 
  subroutine hecmw_allreduce_r1 (hecMESH, s, ntag)
    use hecmw_util
    implicit none
    integer(kind=kint):: ntag
    real(kind=kreal) :: s
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    real(kind=kreal), dimension(1) :: val
    val(1) = s
    call hecmw_allreduce_r(hecmesh, val, 1, ntag )
    s = val(1)
#endif
  end subroutine hecmw_allreduce_r1
 
  !C
  !C***
  !C*** hecmw_allREDUCE_I
  !C***
  !C
  subroutine hecmw_allreduce_i(hecMESH, val, n, ntag)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, ntag
    integer(kind=kint), dimension(n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    integer(kind=kint), dimension(:), allocatable :: VALM, sbuf
 
    allocate (valm(n), sbuf(n))
    sbuf= val
    valm= 0
    if (ntag .eq. hecmw_sum) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_integer, mpi_sum,                      &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    if (ntag .eq. hecmw_max) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_integer, mpi_max,                      &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    if (ntag .eq. hecmw_min) then
      call mpi_allreduce                                              &
        &       (sbuf, valm, n, mpi_integer, mpi_min,                      &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
 
    val= valm
    deallocate (valm, sbuf)
#endif
  end subroutine hecmw_allreduce_i
 
  subroutine hecmw_allreduce_i1 (hecMESH, s, ntag)
    use hecmw_util
    implicit none
    integer(kind=kint)::  ntag, s
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint), dimension(1) :: val
 
    val(1) = s
    call hecmw_allreduce_i(hecmesh, val, 1, ntag )
    s = val(1)
#endif
  end subroutine hecmw_allreduce_i1
 
  subroutine hecmw_allreduce_l1 (hecMESH, flag, ntag)
    use hecmw_util
    implicit none
    integer(kind=kint):: ntag
    logical :: flag
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    logical :: flagM
 
    flagm = .false.
    if (ntag .eq. hecmw_lor) then
      call mpi_allreduce                                              &
        &       (flag, flagm, 1, mpi_logical, mpi_lor,                    &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    if (ntag .eq. hecmw_land) then
      call mpi_allreduce                                              &
        &       (flag, flagm, 1, mpi_logical, mpi_land,                   &
        &        hecmesh%MPI_COMM, ierr)
    endif
 
    flag = flagm
#endif
  end subroutine hecmw_allreduce_l1
 
  !C
  !C***
  !C*** hecmw_bcast_R
  !C***
  !C
  subroutine hecmw_bcast_r (hecMESH, val, n, nbase)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nbase
    real(kind=kreal), dimension(n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n, mpi_double_precision, nbase, hecmesh%MPI_COMM, ierr)
#endif
  end subroutine hecmw_bcast_r
 
  subroutine hecmw_bcast_r_comm (val, n, nbase, comm)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nbase
    real(kind=kreal), dimension(n) :: val
    integer(kind=kint):: comm
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n, mpi_double_precision, nbase, comm, ierr)
#endif
  end subroutine hecmw_bcast_r_comm
 
  subroutine hecmw_bcast_r1 (hecMESH, s, nbase)
    use hecmw_util
    implicit none
    integer(kind=kint):: nbase, ierr
    real(kind=kreal) :: s
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    real(kind=kreal), dimension(1) :: val
    val(1)=s
    call mpi_bcast (val, 1, mpi_double_precision, nbase, hecmesh%MPI_COMM, ierr)
    s = val(1)
#endif
  end subroutine hecmw_bcast_r1
 
  subroutine hecmw_bcast_r1_comm (s, nbase, comm)
    use hecmw_util
    implicit none
    integer(kind=kint):: nbase
    real(kind=kreal) :: s
    integer(kind=kint):: comm
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    real(kind=kreal), dimension(1) :: val
    val(1)=s
    call mpi_bcast (val, 1, mpi_double_precision, nbase, comm, ierr)
    s = val(1)
#endif
  end subroutine hecmw_bcast_r1_comm
  !C
  !C***
  !C*** hecmw_bcast_I
  !C***
  !C
  subroutine hecmw_bcast_i (hecMESH, val, n, nbase)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nbase
    integer(kind=kint), dimension(n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n, mpi_integer, nbase, hecmesh%MPI_COMM, ierr)
#endif
  end subroutine hecmw_bcast_i
 
  subroutine hecmw_bcast_i_comm (val, n, nbase, comm)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nbase
    integer(kind=kint), dimension(n) :: val
    integer(kind=kint):: comm
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n, mpi_integer, nbase, comm, ierr)
#endif
  end subroutine hecmw_bcast_i_comm
 
  subroutine hecmw_bcast_i1 (hecMESH, s, nbase)
    use hecmw_util
    implicit none
    integer(kind=kint):: nbase, s
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    integer(kind=kint), dimension(1) :: val
    val(1) = s
    call mpi_bcast (val, 1, mpi_integer, nbase, hecmesh%MPI_COMM, ierr)
    s = val(1)
#endif
  end subroutine hecmw_bcast_i1
 
  subroutine hecmw_bcast_i1_comm (s, nbase, comm)
    use hecmw_util
    implicit none
    integer(kind=kint):: nbase, s
    integer(kind=kint):: comm
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    integer(kind=kint), dimension(1) :: val
    val(1) = s
    call mpi_bcast (val, 1, mpi_integer, nbase, comm, ierr)
    s = val(1)
#endif
  end subroutine hecmw_bcast_i1_comm
  !C
  !C***
  !C*** hecmw_bcast_C
  !C***
  !C
  subroutine hecmw_bcast_c (hecMESH, val, n, nn, nbase)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nn, nbase
    character(len=n) :: val(nn)
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n*nn, mpi_character, nbase, hecmesh%MPI_COMM,&
      &                                                 ierr)
#endif
  end subroutine hecmw_bcast_c
 
  subroutine hecmw_bcast_c_comm (val, n, nn, nbase, comm)
    use hecmw_util
    implicit none
    integer(kind=kint):: n, nn, nbase
    character(len=n) :: val(nn)
    integer(kind=kint):: comm
#ifndef HECMW_SERIAL
    integer(kind=kint):: ierr
    call mpi_bcast (val, n*nn, mpi_character, nbase, comm,&
      &                                                 ierr)
#endif
  end subroutine hecmw_bcast_c_comm
 
  !C
  !C***
  !C*** hecmw_assemble_R
  !C***
  subroutine hecmw_assemble_r (hecMESH, val, n, m)
    use hecmw_util
    use  hecmw_solver_sr
 
    implicit none
    integer(kind=kint):: n, m
    real(kind=kreal), dimension(m*n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ns, nr
    real(kind=kreal), dimension(:), allocatable :: ws, wr
 
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    ns = hecmesh%import_index(hecmesh%n_neighbor_pe)
    nr = hecmesh%export_index(hecmesh%n_neighbor_pe)
 
    allocate (ws(m*ns), wr(m*nr))
    call hecmw_solve_rev_send_recv                                    &
      &   ( n, m, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,            &
      &     hecmesh%import_index, hecmesh%import_item,                   &
      &     hecmesh%export_index, hecmesh%export_item,                   &
      &     ws, wr, val , hecmesh%MPI_COMM, hecmesh%my_rank)
    deallocate (ws, wr)
#endif
  end subroutine hecmw_assemble_r
 
  !C
  !C***
  !C*** hecmw_assemble_I
  !C***
  subroutine hecmw_assemble_i (hecMESH, val, n, m)
    use hecmw_util
    use  hecmw_solver_sr_i
 
    implicit none
    integer(kind=kint):: n, m
    integer(kind=kint), dimension(m*n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ns, nr
    integer(kind=kint), dimension(:), allocatable :: WS, WR
 
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    ns = hecmesh%import_index(hecmesh%n_neighbor_pe)
    nr = hecmesh%export_index(hecmesh%n_neighbor_pe)
 
    allocate (ws(m*ns), wr(m*nr))
    call hecmw_solve_rev_send_recv_i                                    &
      &   ( n, m, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,            &
      &     hecmesh%import_index, hecmesh%import_item,                   &
      &     hecmesh%export_index, hecmesh%export_item,                   &
      &     ws, wr, val , hecmesh%MPI_COMM, hecmesh%my_rank)
    deallocate (ws, wr)
#endif
  end subroutine hecmw_assemble_i
 
  !C
  !C***
  !C*** hecmw_update_R
  !C***
  !C
  subroutine hecmw_update_r (hecMESH, val, n, m)
    use hecmw_util
    use  hecmw_solver_sr
 
    implicit none
    integer(kind=kint):: n, m
    real(kind=kreal), dimension(m*n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ns, nr
    real(kind=kreal), dimension(:), allocatable :: ws, wr
 
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    ns = hecmesh%export_index(hecmesh%n_neighbor_pe)
    nr = hecmesh%import_index(hecmesh%n_neighbor_pe)
 
    allocate (ws(m*ns), wr(m*nr))
    call hecmw_solve_send_recv                                     &
      &   ( n, m, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,            &
      &     hecmesh%import_index, hecmesh%import_item,                   &
      &     hecmesh%export_index, hecmesh%export_item,                   &
      &     ws, wr, val , hecmesh%MPI_COMM, hecmesh%my_rank)
    deallocate (ws, wr)
#endif
  end subroutine hecmw_update_r
 
  !C
  !C***
  !C*** hecmw_update_R_async
  !C***
  !C
  !C    REAL
  !C
  subroutine hecmw_update_r_async (hecMESH, val, n, m, ireq)
    use hecmw_util
    use  hecmw_solver_sr
    implicit none
    integer(kind=kint):: n, m, ireq
    real(kind=kreal), dimension(m*n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    call hecmw_solve_isend_irecv                                   &
      &   ( n, m, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,            &
      &     hecmesh%import_index, hecmesh%import_item,                   &
      &     hecmesh%export_index, hecmesh%export_item,                   &
      &     val , hecmesh%MPI_COMM, hecmesh%my_rank, ireq)
#endif
  end subroutine hecmw_update_r_async
 
  !C
  !C***
  !C*** hecmw_update_R_wait
  !C***
  !C
  !C    REAL
  !C
  subroutine hecmw_update_r_wait (hecMESH, ireq)
    use hecmw_util
    use  hecmw_solver_sr
    implicit none
    integer(kind=kint):: ireq
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    call hecmw_solve_isend_irecv_wait(hecmesh%n_dof, ireq )
#endif
  end subroutine hecmw_update_r_wait
 
 
  !C
  !C***
  !C*** hecmw_update_I
  !C***
  !C
  subroutine hecmw_update_i (hecMESH, val, n, m)
    use hecmw_util
    use  hecmw_solver_sr_i
 
    implicit none
    integer(kind=kint):: n, m
    integer(kind=kint), dimension(m*n) :: val
    type (hecmwST_local_mesh) :: hecMESH
#ifndef HECMW_SERIAL
    integer(kind=kint):: ns, nr
    integer(kind=kint), dimension(:), allocatable :: WS, WR
 
    if( hecmesh%n_neighbor_pe == 0 ) return
 
    ns = hecmesh%export_index(hecmesh%n_neighbor_pe)
    nr = hecmesh%import_index(hecmesh%n_neighbor_pe)
 
    allocate (ws(m*ns), wr(m*nr))
    call hecmw_solve_send_recv_i                                    &
      &   ( n, m, hecmesh%n_neighbor_pe, hecmesh%neighbor_pe,            &
      &     hecmesh%import_index, hecmesh%import_item,                   &
      &     hecmesh%export_index, hecmesh%export_item,                   &
      &     ws, wr, val , hecmesh%MPI_COMM, hecmesh%my_rank)
    deallocate (ws, wr)
#endif
  end subroutine hecmw_update_i
 
end module m_hecmw_comm_f