feature(communication neighbor a2av)

refactored psi_dswapdata:
- added module support for psi_dswapdata_vect
- added communicator get in psi_dswapdata_vect

- refactored psi_dswapdata_vect as a wrapper that calls either baseline comm (Isend/Irecv) or neighbor a2av
- added private routines (without keyworkd module) for baseline communication and neighbor a2av communication

- added same support for multivectors

TODO: delete work as parameter from psi_dswapdata_vect (?)

base/comm/internals/psi_dswapdata.F90

@@ -92,7 +92,7 @@
 submodule (psi_d_comm_v_mod)  psi_d_swapdata_impl
   use psb_base_mod
 contains
-  subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
+  module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
 
 #ifdef PSB_MPI_MOD
     use mpi
@@ -122,6 +122,8 @@ contains
     call psb_erractionsave(err_act)
 
     ctxt = desc_a%get_context()
+
+    ! get communication from context -- this can be eliminated since it is not passed to psi_swapdata
     icomm = ctxt%get_mpic()
     call psb_info(ctxt,me,np) 
     if (np == -1) then
@@ -171,6 +173,8 @@ contains
 !   The real workhorse: the outer routine will only choose the index list
 !   this one takes the index list and does the actual exchange. 
 !   
+! This is a wrapper function that calls different communication schemes depending 
+! on the flag variable.
 !   
 ! 
   module subroutine psi_dswap_vidx_vect(ctxt,flag,beta,y,idx, &
@@ -185,10 +189,107 @@ contains
 #endif
 
     type(psb_ctxt_type), intent(in)             :: ctxt
+  !integer(psb_mpk_), intent(in)               :: icomm
   integer(psb_ipk_), intent(in)               :: flag
   integer(psb_ipk_), intent(out)              :: info
   class(psb_d_base_vect_type)                 :: y
-    real(psb_dpk_)           :: beta
+  real(psb_dpk_), intent(in)                  :: beta
+  real(psb_dpk_), target                      :: work(:)
+  class(psb_i_base_vect_type), intent(inout)  :: idx
+  integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
+
+  ! local variables used to detect the communication scheme
+  logical                                     :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait
+  logical                                     :: baseline, neighbor_a2av
+
+  ! local variable used for get the communicator
+  integer(psb_mpk_)                           :: icomm
+
+  ! error handling variables
+  integer(psb_ipk_)                           :: err_act
+  integer(psb_mpk_)                           :: me, np
+  character(len=30)                           :: name
+
+
+  info=psb_success_
+  name='psi_dswap_vidx_vect'
+  call psb_erractionsave(err_act)
+  call psb_info(ctxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  swap_mpi    = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync   = iand(flag,psb_swap_sync_) /= 0
+  swap_send   = iand(flag,psb_swap_send_) /= 0
+  swap_recv   = iand(flag,psb_swap_recv_) /= 0
+  swap_start  = iand(flag,psb_swap_start_) /= 0
+  swap_wait   = iand(flag,psb_swap_wait_) /= 0
+
+  baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync
+  neighbor_a2av = swap_start .or. swap_wait 
+
+  icomm = ctxt%get_mpic()
+
+  if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then 
+    info=psb_err_mpi_error_
+    call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true')
+    goto 9999
+  end if
+
+
+  if (baseline) then 
+    call psi_dswap_baseline_vect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+    if (info /= psb_success_) then 
+      call psb_errpush(info,name,a_err='baseline swap')
+      goto 9999
+    end if
+  else if (neighbor_a2av) then 
+    call psi_dswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+    if (info /= psb_success_) then 
+      call psb_errpush(info,name,a_err='neighbor a2av swap')
+      goto 9999
+    end if
+  else 
+    info = psb_err_mpi_error_
+    call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true')
+    goto 9999
+  end if
+  
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ctxt,err_act)
+
+  return
+  end subroutine psi_dswap_vidx_vect
+
+
+!
+! subroutine psi_dswap_baseline_vect
+! This performs Isend/Irecv as a baseline communication mode
+!
+subroutine psi_dswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, &
+    & totxch,totsnd,totrcv,work,info)
+
+
+#ifdef PSB_MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef PSB_MPI_H
+  include 'mpif.h'
+#endif
+
+  type(psb_ctxt_type), intent(in)             :: ctxt
+  integer(psb_mpk_), intent(in)               :: icomm
+  integer(psb_ipk_), intent(in)               :: flag
+  integer(psb_ipk_), intent(out)              :: info
+  class(psb_d_base_vect_type)                 :: y
+  real(psb_dpk_), intent(in)                  :: beta
   real(psb_dpk_), target                      :: work(:)
   class(psb_i_base_vect_type), intent(inout)  :: idx
   integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
@@ -197,7 +298,6 @@ contains
   integer(psb_mpk_) :: np, me
   integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
       & iret, nesd, nerv
-    integer(psb_mpk_) :: icomm
   integer(psb_mpk_), allocatable :: prcid(:)
   integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,&
       & snd_pt, rcv_pt, pnti, n
@@ -207,7 +307,7 @@ contains
   character(len=20)  :: name
 
   info = psb_success_
-    name='psi_swap_datav'
+  name = 'psi_dswap_baseline_vect'
   call psb_erractionsave(err_act)
   call psb_info(ctxt,me,np) 
   if (np == -1) then
@@ -215,13 +315,13 @@ contains
     call psb_errpush(info,name)
     goto 9999
   endif
-    icomm = ctxt%get_mpic()
 
   n=1
   swap_mpi  = iand(flag,psb_swap_mpi_) /= 0
   swap_sync = iand(flag,psb_swap_sync_) /= 0
   swap_send = iand(flag,psb_swap_send_) /= 0
   swap_recv = iand(flag,psb_swap_recv_) /= 0
+
   do_send = swap_mpi .or. swap_sync .or. swap_send
   do_recv = swap_mpi .or. swap_sync .or. swap_recv
 
@@ -237,7 +337,7 @@ contains
         ! Unfinished communication? Something is wrong....
         !
         info=psb_err_mpi_error_
-          call psb_errpush(info,name,m_err=(/-2/))
+        call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....')
         goto 9999
       end if
     end if
@@ -410,7 +510,170 @@ contains
 9999 call psb_error_handler(ctxt,err_act)
 
   return
-  end subroutine psi_dswap_vidx_vect
+end subroutine psi_dswap_baseline_vect
+
+
+
+subroutine psi_dswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, &
+    & totxch,totsnd,totrcv,work,info)
+
+#ifdef PSB_MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef PSB_MPI_H
+  include 'mpif.h'
+#endif
+
+  type(psb_ctxt_type), intent(in)             :: ctxt
+  integer(psb_mpk_), intent(in)               :: icomm
+  integer(psb_ipk_), intent(in)               :: flag
+  integer(psb_ipk_), intent(out)              :: info
+  class(psb_d_base_vect_type)                 :: y
+  real(psb_dpk_), intent(in)                  :: beta
+  real(psb_dpk_), target                      :: work(:)
+  class(psb_i_base_vect_type), intent(inout)  :: idx
+  integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpk_)                           :: np, me
+  integer(psb_mpk_)                           :: iret, p2pstat(mpi_status_size)
+  integer(psb_ipk_)                           :: err_act, topology_total_send, topology_total_recv, buffer_size
+  logical                                     :: do_start, do_wait
+  logical, parameter                          :: debug = .false.
+  character(len=30)                           :: name
+
+
+  info = psb_success_
+  name = 'psi_dswap_nbr_vect'
+  call psb_erractionsave(err_act)
+  call psb_info(ctxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  do_start = iand(flag,psb_swap_start_) /= 0
+  do_wait  = iand(flag,psb_swap_wait_)  /= 0
+
+  call idx%sync()
+
+  ! ---------------------------------------------------------
+  !  START phase: build topology (if needed), gather, post MPI
+  ! ---------------------------------------------------------
+  if (do_start) then
+    if(debug) write(*,*) me,' nbr_vect: starting data exchange'
+    ! Lazy initialization: build the topology on first call
+    if (.not. y%neighbor_topology%is_initialized) then
+      if (debug) write(*,*) me,' nbr_vect: building topology'
+      call y%neighbor_topology%init(idx%v, totxch, totsnd, totrcv, &
+          & ctxt, icomm, info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_, name, &
+            & a_err='neighbor_topology_init')
+        goto 9999
+      end if
+    end if
+
+    topology_total_send = y%neighbor_topology%total_send
+    topology_total_recv = y%neighbor_topology%total_recv
+
+    ! Buffer layout:
+    !   combuf(1 : total_send)                       = send area
+    !   combuf(total_send+1 : total_send+total_recv) = recv area
+    buffer_size = topology_total_send + topology_total_recv
+
+    call y%new_buffer(buffer_size, info)
+    if (info /= 0) then
+      call psb_errpush(psb_err_alloc_dealloc_, name)
+      goto 9999
+    end if
+    y%communication_handle = mpi_request_null
+
+    ! Gather send data into contiguous send buffer (polymorphic for GPU)
+    if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems'
+    call y%gth(int(topology_total_send,psb_mpk_), &
+        & y%neighbor_topology%send_indexes, &
+        & y%combuf(1:topology_total_send))
+
+    ! Wait for device (important for GPU subclasses)
+    call y%device_wait()
+
+    ! Post non-blocking neighborhood alltoallv
+    if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv'
+    call mpi_ineighbor_alltoallv( &
+        & y%combuf(1),                        &  ! send buffer
+        & y%neighbor_topology%send_counts,     &
+        & y%neighbor_topology%send_displs,     &
+        & psb_mpi_r_dpk_,                     &
+        & y%combuf(topology_total_send + 1),       &  ! recv buffer
+        & y%neighbor_topology%recv_counts,     &
+        & y%neighbor_topology%recv_displs,     &
+        & psb_mpi_r_dpk_,                     &
+        & y%neighbor_topology%graph_comm,      &
+        & y%communication_handle, iret)
+    if (iret /= mpi_success) then
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/iret/))
+      goto 9999
+    end if
+
+  end if ! do_start
+
+  ! ---------------------------------------------------------
+  !  WAIT phase: complete MPI, scatter received data
+  ! ---------------------------------------------------------
+  if (do_wait) then
+
+    if (y%communication_handle == mpi_request_null) then
+      ! No matching start? Something is wrong
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/-2/))
+      goto 9999
+    end if
+
+    topology_total_send = y%neighbor_topology%total_send
+    topology_total_recv = y%neighbor_topology%total_recv
+
+    ! Wait for the non-blocking collective to complete
+    if (debug) write(*,*) me,' nbr_vect: waiting on MPI request'
+    call mpi_wait(y%communication_handle, p2pstat, iret)
+    if (iret /= mpi_success) then
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/iret/))
+      goto 9999
+    end if
+
+    ! Scatter received data to local vector positions (polymorphic for GPU)
+    if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems'
+    call y%sct(int(topology_total_recv,psb_mpk_), &
+        & y%neighbor_topology%recv_indexes, &
+        & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), &
+        & beta)
+
+
+    ! Clean up
+    y%communication_handle = mpi_request_null
+    call y%device_wait()
+    call y%maybe_free_buffer(info)
+    if (info /= 0) then
+      call psb_errpush(psb_err_alloc_dealloc_, name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' nbr_vect: done'
+
+  end if ! do_wait
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ctxt,err_act)
+
+  return
+end subroutine psi_dswap_neighbor_topology_vect
+
+
 
   !
   !
@@ -512,10 +775,105 @@ contains
 #endif
 
     type(psb_ctxt_type), intent(in)             :: ctxt
+  !integer(psb_mpk_), intent(in)               :: icomm
   integer(psb_ipk_), intent(in)               :: flag
   integer(psb_ipk_), intent(out)              :: info
   class(psb_d_base_multivect_type)            :: y
-    real(psb_dpk_)         :: beta
+  real(psb_dpk_), intent(in)                  :: beta
+  real(psb_dpk_), target                      :: work(:)
+  class(psb_i_base_vect_type), intent(inout)  :: idx
+  integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
+
+  ! local variables used to detect the communication scheme
+  logical                                     :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait
+  logical                                     :: baseline, neighbor_a2av
+
+  ! local variable used to get communicator
+  integer(psb_mpk_)                           :: icomm
+
+  ! error handling variables
+  integer(psb_ipk_)                           :: err_act
+  integer(psb_mpk_)                           :: me, np
+  character(len=30)                           :: name
+
+
+  info=psb_success_
+  name='psi_dswap_vidx_multivect'
+  call psb_erractionsave(err_act)
+  call psb_info(ctxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+
+  swap_mpi    = iand(flag,psb_swap_mpi_) /= 0
+  swap_sync   = iand(flag,psb_swap_sync_) /= 0
+  swap_send   = iand(flag,psb_swap_send_) /= 0
+  swap_recv   = iand(flag,psb_swap_recv_) /= 0
+  swap_start  = iand(flag,psb_swap_start_) /= 0
+  swap_wait   = iand(flag,psb_swap_wait_) /= 0
+
+  baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync
+  neighbor_a2av = swap_start .or. swap_wait 
+
+  icomm = ctxt%get_mpic()
+
+  if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then 
+    info=psb_err_mpi_error_
+    call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true')
+    goto 9999
+  end if
+
+
+  if (baseline) then 
+    call psi_dswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+    if (info /= psb_success_) then 
+      call psb_errpush(info,name,a_err='baseline swap')
+      goto 9999
+    end if
+  else if (neighbor_a2av) then 
+    call psi_dswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
+    if (info /= psb_success_) then 
+      call psb_errpush(info,name,a_err='neighbor a2av swap')
+      goto 9999
+    end if
+  else 
+    info = psb_err_mpi_error_
+    call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true')
+    goto 9999
+  end if
+  
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ctxt,err_act)
+
+  return
+  end subroutine psi_dswap_vidx_multivect
+
+
+
+
+subroutine psi_dswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+
+#ifdef PSB_MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef PSB_MPI_H
+  include 'mpif.h'
+#endif
+
+  type(psb_ctxt_type), intent(in)             :: ctxt
+  integer(psb_mpk_), intent(in)               :: icomm
+  integer(psb_ipk_), intent(in)               :: flag
+  integer(psb_ipk_), intent(out)              :: info
+  class(psb_d_base_multivect_type)            :: y
+  real(psb_dpk_), intent(in)                  :: beta
   real(psb_dpk_), target                      :: work(:)
   class(psb_i_base_vect_type), intent(inout)  :: idx
   integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
@@ -523,7 +881,6 @@ contains
   ! locals
   integer(psb_mpk_)                           :: np, me, nesd, nerv, n
   integer(psb_mpk_)                           :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
-    integer(psb_mpk_) :: icomm
   integer(psb_mpk_), allocatable              :: prcid(:)
   integer(psb_ipk_)                           :: err_act, i, idx_pt, totsnd_, totrcv_,&
        & snd_pt, rcv_pt, pnti
@@ -533,7 +890,7 @@ contains
   character(len=20)                           :: name
 
   info = psb_success_
-    name='psi_swap_datav'
+  name = 'psi_dswap_baseline_multivect'
   call psb_erractionsave(err_act)
   call psb_info(ctxt,me,np) 
   if (np == -1) then
@@ -541,7 +898,6 @@ contains
     call psb_errpush(info,name)
     goto 9999
   endif
-    icomm = ctxt%get_mpic()
 
   n = y%get_ncols()
 
@@ -742,6 +1098,169 @@ contains
 9999 call psb_error_handler(ctxt,err_act)
 
   return
-  end subroutine psi_dswap_vidx_multivect
+end subroutine psi_dswap_baseline_vidx_multivect
+
+
+
+subroutine psi_dswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, &
+     & totxch,totsnd,totrcv,work,info)
+
+#ifdef PSB_MPI_MOD
+  use mpi
+#endif
+  implicit none
+#ifdef PSB_MPI_H
+  include 'mpif.h'
+#endif
+
+  type(psb_ctxt_type), intent(in)             :: ctxt
+  integer(psb_mpk_), intent(in)               :: icomm
+  integer(psb_ipk_), intent(in)               :: flag
+  integer(psb_ipk_), intent(out)              :: info
+  class(psb_d_base_multivect_type)            :: y
+  real(psb_dpk_), intent(in)                  :: beta
+  real(psb_dpk_), target                      :: work(:)
+  class(psb_i_base_vect_type), intent(inout)  :: idx
+  integer(psb_ipk_), intent(in)               :: totxch,totsnd, totrcv
+
+  ! locals
+  integer(psb_mpk_)                           :: np, me
+  integer(psb_mpk_)                           :: iret, p2pstat(mpi_status_size)
+  integer(psb_ipk_)                           :: err_act, topology_total_send, topology_total_recv, buffer_size
+  logical                                     :: do_start, do_wait
+  logical, parameter                          :: debug = .false.
+  character(len=30)                           :: name
+
+
+  info = psb_success_
+  name = 'psi_dswap_nbr_vect'
+  call psb_erractionsave(err_act)
+  call psb_info(ctxt,me,np) 
+  if (np == -1) then
+    info=psb_err_context_error_
+    call psb_errpush(info,name)
+    goto 9999
+  endif
+
+  do_start = iand(flag,psb_swap_start_) /= 0
+  do_wait  = iand(flag,psb_swap_wait_)  /= 0
+
+  call idx%sync()
+
+  ! ---------------------------------------------------------
+  !  START phase: build topology (if needed), gather, post MPI
+  ! ---------------------------------------------------------
+  if (do_start) then
+    if(debug) write(*,*) me,' nbr_vect: starting data exchange'
+    ! Lazy initialization: build the topology on first call
+    if (.not. y%neighbor_topology%is_initialized) then
+      if (debug) write(*,*) me,' nbr_vect: building topology'
+      call y%neighbor_topology%init(idx%v, totxch, totsnd, totrcv, &
+          & ctxt, icomm, info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_, name, &
+            & a_err='neighbor_topology_init')
+        goto 9999
+      end if
+    end if
+
+    topology_total_send = y%neighbor_topology%total_send
+    topology_total_recv = y%neighbor_topology%total_recv
+
+    ! Buffer layout:
+    !   combuf(1 : total_send)                       = send area
+    !   combuf(total_send+1 : total_send+total_recv) = recv area
+    buffer_size = topology_total_send + topology_total_recv
+
+    call y%new_buffer(buffer_size, info)
+    if (info /= 0) then
+      call psb_errpush(psb_err_alloc_dealloc_, name)
+      goto 9999
+    end if
+    y%communication_handle = mpi_request_null
+
+    ! Gather send data into contiguous send buffer (polymorphic for GPU)
+    if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems'
+    call y%gth(int(topology_total_send,psb_mpk_), &
+        & y%neighbor_topology%send_indexes, &
+        & y%combuf(1:topology_total_send))
+
+    ! Wait for device (important for GPU subclasses)
+    call y%device_wait()
+
+    ! Post non-blocking neighborhood alltoallv
+    if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv'
+    call mpi_ineighbor_alltoallv( &
+        & y%combuf(1),                        &  ! send buffer
+        & y%neighbor_topology%send_counts,     &
+        & y%neighbor_topology%send_displs,     &
+        & psb_mpi_r_dpk_,                     &
+        & y%combuf(topology_total_send + 1),       &  ! recv buffer
+        & y%neighbor_topology%recv_counts,     &
+        & y%neighbor_topology%recv_displs,     &
+        & psb_mpi_r_dpk_,                     &
+        & y%neighbor_topology%graph_comm,      &
+        & y%communication_handle, iret)
+    if (iret /= mpi_success) then
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/iret/))
+      goto 9999
+    end if
+
+  end if ! do_start
+
+  ! ---------------------------------------------------------
+  !  WAIT phase: complete MPI, scatter received data
+  ! ---------------------------------------------------------
+  if (do_wait) then
+
+    if (y%communication_handle == mpi_request_null) then
+      ! No matching start? Something is wrong
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/-2/))
+      goto 9999
+    end if
+
+    topology_total_send = y%neighbor_topology%total_send
+    topology_total_recv = y%neighbor_topology%total_recv
+
+    ! Wait for the non-blocking collective to complete
+    if (debug) write(*,*) me,' nbr_vect: waiting on MPI request'
+    call mpi_wait(y%communication_handle, p2pstat, iret)
+    if (iret /= mpi_success) then
+      info = psb_err_mpi_error_
+      call psb_errpush(info, name, m_err=(/iret/))
+      goto 9999
+    end if
+
+    ! Scatter received data to local vector positions (polymorphic for GPU)
+    if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems'
+    call y%sct(int(topology_total_recv,psb_mpk_), &
+        & y%neighbor_topology%recv_indexes, &
+        & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), &
+        & beta)
+
+
+    ! Clean up
+    y%communication_handle = mpi_request_null
+    call y%device_wait()
+    call y%maybe_free_buffer(info)
+    if (info /= 0) then
+      call psb_errpush(psb_err_alloc_dealloc_, name)
+      goto 9999
+    end if
+    if (debug) write(*,*) me,' nbr_vect: done'
+
+  end if ! do_wait
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(ctxt,err_act)
+
+  return
+end subroutine psi_dswap_neighbor_topology_multivect
+
+
 end submodule psi_d_swapdata_impl