hecmw_adapt_real_sr.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 hecmw_adapt_real_sr
contains
  !C
  !C***
  !C*** REAL_SEND_RECV
  !C***
  !C
  subroutine  hecmw_adapt_real_send_recv                            &
      &                ( n,   neibpetot,neibpe,stack_import, nod_import, &
      &                                        stack_export, nod_export, &
      &                  ws, wr, x, solver_comm,my_rank, nb, m)
 
    use hecmw_util
    implicit real*8 (a-h,o-z)
 
    integer(kind=kint )                , intent(in)   ::  N, m
    integer(kind=kint )                , intent(in)   ::  NEIBPETOT
    integer(kind=kint ), pointer :: NEIBPE      (:)
    integer(kind=kint ), pointer :: STACK_IMPORT(:)
    integer(kind=kint ), pointer :: NOD_IMPORT  (:)
    integer(kind=kint ), pointer :: STACK_EXPORT(:)
    integer(kind=kint ), pointer :: NOD_EXPORT  (:)
    real   (kind=kreal), dimension(NB*m), intent(inout):: ws
    real   (kind=kreal), dimension(NB*m), intent(inout):: wr
    real   (kind=kreal), dimension(NB*N), intent(inout):: x
    integer(kind=kint )                 , intent(in)   ::SOLVER_COMM
    integer(kind=kint )                 , intent(in)   :: my_rank
 
    integer(kind=kint ), dimension(:,:), save, allocatable :: sta1
    integer(kind=kint ), dimension(:,:), save, allocatable :: sta2
    integer(kind=kint ), dimension(:  ), save, allocatable :: req1
    integer(kind=kint ), dimension(:  ), save, allocatable :: req2
 
    integer(kind=kint ), save :: NFLAG
    data nflag/0/
 
    !C
    !C-- INIT.
    if (nflag.eq.0) then
      allocate (sta1(mpi_status_size,neibpetot))
      allocate (sta2(mpi_status_size,neibpetot))
      allocate (req1(neibpetot))
      allocate (req2(neibpetot))
      nflag= 1
    endif
 
    !C
    !C-- SEND
    do neib= 1, neibpetot
      istart= stack_export(neib-1)
      inum  = stack_export(neib  ) - istart
 
      do k= istart+1, istart+inum
        ii= nb*nod_export(k) - nb
        ik= nb*k             - nb
        do j= 1, nb
          ws(ik+j)= x(ii+j)
        enddo
      enddo
      call mpi_isend (ws(nb*istart+1), nb*inum,mpi_double_precision,  &
        &                  neibpe(neib), 0, solver_comm, req1(neib), ierr)
    enddo
 
    !C
    !C-- RECEIVE
    do neib= 1, neibpetot
      istart= stack_import(neib-1)
      inum  = stack_import(neib  ) - istart
      call mpi_irecv (wr(nb*istart+1), nb*inum, mpi_double_precision, &
        &                  neibpe(neib), 0, solver_comm, req2(neib), ierr)
    enddo
 
    call mpi_waitall (neibpetot, req2, sta2, ierr)
 
    do neib= 1, neibpetot
      istart= stack_import(neib-1)
      inum  = stack_import(neib  ) - istart
      do k= istart+1, istart+inum
        ii= nb*nod_import(k) - nb
        ik= nb*k             - nb
        do j= 1, nb
          x(ii+j)= wr(ik+j)
        enddo
      enddo
    enddo
 
    call mpi_waitall (neibpetot, req1, sta1, ierr)
 
  end subroutine hecmw_adapt_real_send_recv
end module     hecmw_adapt_real_sr