|
|
|
@ -1038,7 +1038,7 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
|
|
|
class(psb_i_base_vect_type) :: y
|
|
|
|
class(psb_i_base_vect_type) :: y
|
|
|
|
integer(psb_ipk_) :: beta
|
|
|
|
integer(psb_ipk_) :: beta
|
|
|
|
integer(psb_ipk_), target :: work(:)
|
|
|
|
integer(psb_ipk_), target :: work(:)
|
|
|
|
type(psb_desc_type),target :: desc_a
|
|
|
|
type(psb_desc_type), target :: desc_a
|
|
|
|
integer(psb_ipk_), optional :: data
|
|
|
|
integer(psb_ipk_), optional :: data
|
|
|
|
|
|
|
|
|
|
|
|
! locals
|
|
|
|
! locals
|
|
|
|
@ -1073,7 +1073,6 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
|
|
|
|
data_ = psb_comm_halo_
|
|
|
|
data_ = psb_comm_halo_
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
|
|
|
|
|
|
|
|
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
|
|
|
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
|
|
|
|
@ -1105,381 +1104,11 @@ end subroutine psi_iswapdata_vect
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!
|
|
|
|
subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
use psi_mod, psb_protect_name => psi_iswapidx_vect
|
|
|
|
|
|
|
|
use psb_error_mod
|
|
|
|
|
|
|
|
use psb_desc_mod
|
|
|
|
|
|
|
|
use psb_penv_mod
|
|
|
|
|
|
|
|
use psb_i_base_vect_mod
|
|
|
|
|
|
|
|
#ifdef MPI_MOD
|
|
|
|
|
|
|
|
use mpi
|
|
|
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
#ifdef MPI_H
|
|
|
|
|
|
|
|
include 'mpif.h'
|
|
|
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
|
|
|
|
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
|
|
|
class(psb_i_base_vect_type) :: y
|
|
|
|
|
|
|
|
integer(psb_ipk_) :: beta
|
|
|
|
|
|
|
|
integer(psb_ipk_), target :: work(:)
|
|
|
|
|
|
|
|
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! locals
|
|
|
|
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
|
|
|
|
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
|
|
|
|
|
|
|
|
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
|
|
|
|
|
|
|
|
& sdsz, rvsz, prcid, rvhd, sdhd
|
|
|
|
|
|
|
|
integer(psb_ipk_) :: nesd, nerv,&
|
|
|
|
|
|
|
|
& err_act, i, idx_pt, totsnd_, totrcv_,&
|
|
|
|
|
|
|
|
& snd_pt, rcv_pt, pnti, n
|
|
|
|
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
|
|
|
|
logical, parameter :: usersend=.false.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
|
|
|
|
|
|
|
#ifdef HAVE_VOLATILE
|
|
|
|
|
|
|
|
volatile :: sndbuf, rcvbuf
|
|
|
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
character(len=20) :: name
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
info=psb_success_
|
|
|
|
|
|
|
|
name='psi_swap_datav'
|
|
|
|
|
|
|
|
call psb_erractionsave(err_act)
|
|
|
|
|
|
|
|
ictxt = iictxt
|
|
|
|
|
|
|
|
icomm = iicomm
|
|
|
|
|
|
|
|
call psb_info(ictxt,me,np)
|
|
|
|
|
|
|
|
if (np == -1) then
|
|
|
|
|
|
|
|
info=psb_err_context_error_
|
|
|
|
|
|
|
|
call psb_errpush(info,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
totrcv_ = totrcv * n
|
|
|
|
|
|
|
|
totsnd_ = totsnd * n
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
|
|
|
|
|
|
|
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
|
|
|
|
|
|
|
& stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
rvhd(:) = mpi_request_null
|
|
|
|
|
|
|
|
sdsz(:) = 0
|
|
|
|
|
|
|
|
rvsz(:) = 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! prepare info for communications
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
brvidx(proc_to_comm) = rcv_pt
|
|
|
|
|
|
|
|
rvsz(proc_to_comm) = nerv
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
bsdidx(proc_to_comm) = snd_pt
|
|
|
|
|
|
|
|
sdsz(proc_to_comm) = nesd
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
totrcv_ = max(totrcv_,1)
|
|
|
|
|
|
|
|
totsnd_ = max(totsnd_,1)
|
|
|
|
|
|
|
|
if((totrcv_+totsnd_) < size(work)) then
|
|
|
|
|
|
|
|
sndbuf => work(1:totsnd_)
|
|
|
|
|
|
|
|
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
|
|
|
|
|
|
|
albf=.false.
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
albf=.true.
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (do_send) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Pack send buffers
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
|
|
|
|
call y%gth(nesd,idx(idx_pt:idx_pt+nesd-1),&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1))
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Case SWAP_MPI
|
|
|
|
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! swap elements using mpi_alltoallv
|
|
|
|
|
|
|
|
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,rcvbuf,rvsz,&
|
|
|
|
|
|
|
|
& brvidx,psb_mpi_ipk_integer,icomm,iret)
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
|
|
|
|
ierr(1) = iret
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else if (swap_sync) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (proc_to_comm < me) then
|
|
|
|
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
|
|
|
|
else if (proc_to_comm > me) then
|
|
|
|
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
|
|
|
|
else if (proc_to_comm == me) then
|
|
|
|
|
|
|
|
if (nesd /= nerv) then
|
|
|
|
|
|
|
|
write(psb_err_unit,*) &
|
|
|
|
|
|
|
|
& 'Fatal error in swapdata: mismatch on self send',&
|
|
|
|
|
|
|
|
& nerv,nesd
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else if (swap_send .and. swap_recv) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! First I post all the non blocking receives
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
|
|
|
|
|
|
|
if ((nerv>0).and.(proc_to_comm /= me)) then
|
|
|
|
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
|
|
|
|
& p2ptag, icomm,rvhd(i),iret)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Then I post all the blocking sends
|
|
|
|
|
|
|
|
if (usersend) call mpi_barrier(icomm,iret)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if ((nesd>0).and.(proc_to_comm /= me)) then
|
|
|
|
|
|
|
|
if (usersend) then
|
|
|
|
|
|
|
|
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
|
|
|
|
& p2ptag,icomm,iret)
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
call mpi_send(sndbuf(snd_pt),nesd,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
|
|
|
|
& p2ptag,icomm,iret)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
|
|
|
|
ierr(1) = iret
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if ((proc_to_comm /= me).and.(nerv>0)) then
|
|
|
|
|
|
|
|
call mpi_wait(rvhd(i),p2pstat,iret)
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
|
|
|
|
ierr(1) = iret
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
else if (proc_to_comm == me) then
|
|
|
|
|
|
|
|
if (nesd /= nerv) then
|
|
|
|
|
|
|
|
write(psb_err_unit,*) &
|
|
|
|
|
|
|
|
& 'Fatal error in swapdata: mismatch on self send',&
|
|
|
|
|
|
|
|
& nerv,nesd
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else if (swap_send) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else if (swap_recv) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (do_recv) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
idx_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
|
|
|
|
call y%sct(nerv,idx(idx_pt:idx_pt+nerv-1),&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
|
|
|
|
|
|
|
& stat=info)
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
deallocate(rvhd,prcid,stat=info)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
9999 call psb_error_handler(ictxt,err_act)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
end subroutine psi_iswapidx_vect
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! Subroutine: psi_iswapvidx_vect
|
|
|
|
|
|
|
|
! Data exchange among processes.
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! Case where the index vector is also encapsulated.
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! The real workhorse: the outer routines will only choose the index list
|
|
|
|
|
|
|
|
! this one takes the index list and does the actual exchange.
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
|
|
|
subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
|
|
|
|
|
|
|
|
|
|
|
|
use psi_mod, psb_protect_name => psi_iswap_vidx_vect
|
|
|
|
use psi_mod, psb_protect_name => psi_iswap_vidx_vect
|
|
|
|
use psb_error_mod
|
|
|
|
use psb_error_mod
|
|
|
|
|
|
|
|
use psb_realloc_mod
|
|
|
|
use psb_desc_mod
|
|
|
|
use psb_desc_mod
|
|
|
|
use psb_penv_mod
|
|
|
|
use psb_penv_mod
|
|
|
|
use psb_i_base_vect_mod
|
|
|
|
use psb_i_base_vect_mod
|
|
|
|
@ -1496,8 +1125,8 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
class(psb_i_base_vect_type) :: y
|
|
|
|
class(psb_i_base_vect_type) :: y
|
|
|
|
integer(psb_ipk_) :: beta
|
|
|
|
integer(psb_ipk_) :: beta
|
|
|
|
integer(psb_ipk_), target :: work(:)
|
|
|
|
integer(psb_ipk_), target :: work(:)
|
|
|
|
class(psb_i_base_vect_type), intent(in) :: idx
|
|
|
|
class(psb_i_base_vect_type), intent(inout) :: idx
|
|
|
|
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
|
|
|
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
|
|
|
|
|
|
|
|
|
|
|
|
! locals
|
|
|
|
! locals
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
integer(psb_mpik_) :: ictxt, icomm, np, me,&
|
|
|
|
@ -1510,7 +1139,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
integer(psb_ipk_) :: ierr(5)
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
& albf,do_send,do_recv
|
|
|
|
logical, parameter :: usersend=.false.
|
|
|
|
logical, parameter :: usersend=.false., debug=.false.
|
|
|
|
|
|
|
|
|
|
|
|
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
|
|
|
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
|
|
|
|
#ifdef HAVE_VOLATILE
|
|
|
|
#ifdef HAVE_VOLATILE
|
|
|
|
@ -1541,159 +1170,65 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
|
|
|
|
|
|
|
|
totrcv_ = totrcv * n
|
|
|
|
totrcv_ = totrcv * n
|
|
|
|
totsnd_ = totsnd * n
|
|
|
|
totsnd_ = totsnd * n
|
|
|
|
|
|
|
|
call idx%sync()
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
|
|
|
|
if (debug) write(*,*) me,'Internal buffer'
|
|
|
|
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
|
|
|
|
if (do_send) then
|
|
|
|
& stat=info)
|
|
|
|
if (allocated(y%comid)) then
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
!
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
! Unfinished communication? Something is wrong....
|
|
|
|
goto 9999
|
|
|
|
!
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
rvhd(:) = mpi_request_null
|
|
|
|
|
|
|
|
sdsz(:) = 0
|
|
|
|
|
|
|
|
rvsz(:) = 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! prepare info for communications
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
brvidx(proc_to_comm) = rcv_pt
|
|
|
|
|
|
|
|
rvsz(proc_to_comm) = nerv
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
bsdidx(proc_to_comm) = snd_pt
|
|
|
|
|
|
|
|
sdsz(proc_to_comm) = nesd
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
allocate(rvhd(totxch),prcid(totxch),stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
totrcv_ = max(totrcv_,1)
|
|
|
|
|
|
|
|
totsnd_ = max(totsnd_,1)
|
|
|
|
|
|
|
|
if((totrcv_+totsnd_) < size(work)) then
|
|
|
|
|
|
|
|
sndbuf => work(1:totsnd_)
|
|
|
|
|
|
|
|
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
|
|
|
|
|
|
|
|
albf=.false.
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
albf=.true.
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (do_send) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Pack send buffers
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
|
|
|
|
call y%gth(idx_pt,nesd,idx,&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1))
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Case SWAP_MPI
|
|
|
|
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! swap elements using mpi_alltoallv
|
|
|
|
|
|
|
|
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,rcvbuf,rvsz,&
|
|
|
|
|
|
|
|
& brvidx,psb_mpi_ipk_integer,icomm,iret)
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
|
|
|
|
ierr(1) = iret
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
ierr(1) = -2
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,'do_send start'
|
|
|
|
else if (swap_sync) then
|
|
|
|
call y%new_buffer(size(idx%v),info)
|
|
|
|
|
|
|
|
call y%new_comid(totxch,info)
|
|
|
|
|
|
|
|
call psb_realloc(totxch,prcid,info)
|
|
|
|
|
|
|
|
! First I post all the non blocking receives
|
|
|
|
pnti = 1
|
|
|
|
pnti = 1
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
do i=1, totxch
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
|
|
|
|
if (proc_to_comm < me) then
|
|
|
|
rcv_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
if ((nerv>0).and.(proc_to_comm /= me)) then
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
else if (proc_to_comm > me) then
|
|
|
|
call mpi_irecv(y%combuf(rcv_pt),nerv,&
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
& p2ptag, icomm,y%comid(i,2),iret)
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
|
|
|
|
else if (proc_to_comm == me) then
|
|
|
|
|
|
|
|
if (nesd /= nerv) then
|
|
|
|
|
|
|
|
write(psb_err_unit,*) &
|
|
|
|
|
|
|
|
& 'Fatal error in swapdata: mismatch on self send',&
|
|
|
|
|
|
|
|
& nerv,nesd
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
|
|
|
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' Gather '
|
|
|
|
|
|
|
|
!
|
|
|
|
else if (swap_send .and. swap_recv) then
|
|
|
|
! Then gather for sending.
|
|
|
|
|
|
|
|
!
|
|
|
|
! First I post all the non blocking receives
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
pnti = 1
|
|
|
|
snd_pt = 1
|
|
|
|
snd_pt = 1
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
do i=1, totxch
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
idx_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
|
|
|
|
call y%gth(idx_pt,nesd,idx)
|
|
|
|
if ((nerv>0).and.(proc_to_comm /= me)) then
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
|
|
|
|
& p2ptag, icomm,rvhd(i),iret)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! Then wait
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
call y%device_wait()
|
|
|
|
|
|
|
|
|
|
|
|
! Then I post all the blocking sends
|
|
|
|
if (debug) write(*,*) me,' isend'
|
|
|
|
if (usersend) call mpi_barrier(icomm,iret)
|
|
|
|
!
|
|
|
|
|
|
|
|
! Then send
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
pnti = 1
|
|
|
|
snd_pt = 1
|
|
|
|
snd_pt = 1
|
|
|
|
@ -1702,48 +1237,70 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
snd_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
|
|
|
|
rcv_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
|
|
|
|
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
|
|
|
|
if ((nesd>0).and.(proc_to_comm /= me)) then
|
|
|
|
if ((nesd>0).and.(proc_to_comm /= me)) then
|
|
|
|
if (usersend) then
|
|
|
|
call mpi_isend(y%combuf(snd_pt),nesd,&
|
|
|
|
call mpi_rsend(sndbuf(snd_pt),nesd,&
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
& p2ptag,icomm,y%comid(i,1),iret)
|
|
|
|
& p2ptag,icomm,iret)
|
|
|
|
end if
|
|
|
|
else
|
|
|
|
|
|
|
|
call mpi_send(sndbuf(snd_pt),nesd,&
|
|
|
|
|
|
|
|
& psb_mpi_ipk_integer,prcid(i),&
|
|
|
|
|
|
|
|
& p2ptag,icomm,iret)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
ierr(1) = iret
|
|
|
|
ierr(1) = iret
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (do_recv) then
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' do_Recv'
|
|
|
|
|
|
|
|
if (.not.allocated(y%comid)) then
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! No matching send? Something is wrong....
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
ierr(1) = -2
|
|
|
|
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
call psb_realloc(totxch,prcid,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' wait'
|
|
|
|
pnti = 1
|
|
|
|
pnti = 1
|
|
|
|
do i=1, totxch
|
|
|
|
do i=1, totxch
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
snd_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
|
|
|
|
rcv_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
|
|
|
|
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
p2ptag = psb_int_swap_tag
|
|
|
|
|
|
|
|
|
|
|
|
if ((proc_to_comm /= me).and.(nerv>0)) then
|
|
|
|
if (proc_to_comm /= me)then
|
|
|
|
call mpi_wait(rvhd(i),p2pstat,iret)
|
|
|
|
if (nesd>0) then
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
call mpi_wait(y%comid(i,1),p2pstat,iret)
|
|
|
|
ierr(1) = iret
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
ierr(1) = iret
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
goto 9999
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if (nerv>0) then
|
|
|
|
|
|
|
|
call mpi_wait(y%comid(i,2),p2pstat,iret)
|
|
|
|
|
|
|
|
if(iret /= mpi_success) then
|
|
|
|
|
|
|
|
ierr(1) = iret
|
|
|
|
|
|
|
|
info=psb_err_mpi_error_
|
|
|
|
|
|
|
|
call psb_errpush(info,name,i_err=ierr)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
else if (proc_to_comm == me) then
|
|
|
|
else if (proc_to_comm == me) then
|
|
|
|
if (nesd /= nerv) then
|
|
|
|
if (nesd /= nerv) then
|
|
|
|
@ -1751,14 +1308,12 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
& 'Fatal error in swapdata: mismatch on self send',&
|
|
|
|
& 'Fatal error in swapdata: mismatch on self send',&
|
|
|
|
& nerv,nesd
|
|
|
|
& nerv,nesd
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
|
|
|
|
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' scatter'
|
|
|
|
else if (swap_send) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
pnti = 1
|
|
|
|
snd_pt = 1
|
|
|
|
snd_pt = 1
|
|
|
|
rcv_pt = 1
|
|
|
|
rcv_pt = 1
|
|
|
|
@ -1766,71 +1321,37 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
if (nesd>0) call psb_snd(ictxt,&
|
|
|
|
idx_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
|
|
|
|
snd_pt = 1+pnti+nerv+psb_n_elem_send_
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
rcv_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
else if (swap_recv) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
if (debug) write(0,*)me,' Received from: ',prcid(i),y%combuf(rcv_pt:rcv_pt+nerv-1)
|
|
|
|
snd_pt = 1
|
|
|
|
call y%sct(rcv_pt,nerv,idx,beta)
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
if (nerv>0) call psb_rcv(ictxt,&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (do_recv) then
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
pnti = 1
|
|
|
|
|
|
|
|
snd_pt = 1
|
|
|
|
|
|
|
|
rcv_pt = 1
|
|
|
|
|
|
|
|
do i=1, totxch
|
|
|
|
|
|
|
|
proc_to_comm = idx%v(pnti+psb_proc_id_)
|
|
|
|
|
|
|
|
nerv = idx%v(pnti+psb_n_elem_recv_)
|
|
|
|
|
|
|
|
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
|
|
|
|
|
|
|
|
idx_pt = 1+pnti+psb_n_elem_recv_
|
|
|
|
|
|
|
|
call y%sct(idx_pt,nerv,idx,&
|
|
|
|
|
|
|
|
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
|
|
|
|
|
|
|
|
rcv_pt = rcv_pt + nerv
|
|
|
|
|
|
|
|
snd_pt = snd_pt + nesd
|
|
|
|
|
|
|
|
pnti = pnti + nerv + nesd + 3
|
|
|
|
|
|
|
|
end do
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! Then wait
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' wait'
|
|
|
|
|
|
|
|
call y%device_wait()
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' free buffer'
|
|
|
|
|
|
|
|
call y%free_buffer(info)
|
|
|
|
|
|
|
|
if (info == 0) call y%free_comid(info)
|
|
|
|
|
|
|
|
if (info /= 0) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if (debug) write(*,*) me,' done'
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
if (swap_mpi) then
|
|
|
|
|
|
|
|
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
|
|
|
|
|
|
|
|
& stat=info)
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
deallocate(rvhd,prcid,stat=info)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
|
|
|
|
|
|
|
|
if(info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,name)
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
return
|
|
|
|
return
|
|
|
|
|
|
|
|
|
|
|
|
9999 call psb_error_handler(ictxt,err_act)
|
|
|
|
9999 call psb_error_handler(ictxt,err_act)
|
|
|
|
|
|
|
|
|
|
|
|
return
|
|
|
|
return
|
|
|
|
end subroutine psi_iswap_vidx_vect
|
|
|
|
end subroutine psi_iswap_vidx_vect
|
|
|
|
|
|
|
|
|
|
|
|
|
Salvatore Filippone
10 years ago