hecmw_adapt_item_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_item_sr
contains
  !C
  !C***
  !C*** hecmw_adapt_ITEM_SEND_RECV
  !C***
  !C
  !C    exchange IMPORT/EXPORT item information
  !C    form communication table
  !C
  subroutine  hecmw_adapt_item_send_recv                            &
      &                ( n, neibpetot, neibpe, stack_import, nod_import, &
      &                                        stack_export, nod_export, &
      &                  ws, wr, solver_comm, my_rank, ntab)
 
    use hecmw_util
 
    integer(kind=kint ), intent(in)   :: N, NEIBPETOT
    integer(kind=kint ), pointer      :: NEIBPE      (:)
    integer(kind=kint ), pointer      :: STACK_IMPORT(:)
    integer(kind=kint ), pointer      :: STACK_EXPORT(:)
    integer(kind=kint ), pointer      :: NOD_IMPORT(:), NOD_EXPORT(:)
 
    integer(kind=kint ), dimension(N*NTAB) :: WS, WR
    integer(kind=kint ),                   :: SOLVER_COMM, 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_import(neib-1)
      inum  = stack_import(neib  ) - istart
      do k= istart+1, istart+inum
        is= (k-1)*ntab
        do jj= 1, ntab
          ws(is+jj)= nod_import(is+jj)
        enddo
      enddo
      is= istart*ntab
      call mpi_isend (ws(is+1), ntab*inum, mpi_integer,               &
        &                  neibpe(neib), 0, solver_comm,                   &
        &                  req1(neib), ierr)
    enddo
 
    !C
    !C-- RECEIVE
    do neib= 1, neibpetot
      istart= stack_export(neib-1)
      inum  = stack_export(neib  ) - istart
      is= istart*ntab
      call mpi_irecv (wr(is+1), ntab*inum, mpi_integer,               &
        &                  neibpe(neib), 0, solver_comm,                   &
        &                  req2(neib), ierr)
    enddo
 
    call mpi_waitall (neibpetot, req2, sta2, ierr)
 
    do neib= 1, neibpetot
      istart= stack_export(neib-1)
      inum  = stack_export(neib  ) - istart
      do k= istart+1, istart+inum
        is= (k-1)*ntab
        do jj= 1, ntab
          nod_export(is+jj)= wr(is+jj)
        enddo
      enddo
    enddo
 
    call mpi_waitall (neibpetot, req1, sta1, ierr)
 
  end subroutine hecmw_adapt_item_send_recv
end module     hecmw_adapt_item_sr