fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas:

Browse Source 
base/internals/psi_cswapdata.F90
 base/internals/psi_cswaptran.F90
 base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/internals/psi_iswapdata.F90
 base/internals/psi_iswaptran.F90
 base/internals/psi_sswapdata.F90
 base/internals/psi_sswaptran.F90
 base/internals/psi_zswapdata.F90
 base/internals/psi_zswaptran.F90
 base/modules/psi_c_mod.f90
 base/modules/psi_d_mod.f90
 base/modules/psi_i_mod.f90
 base/modules/psi_s_mod.f90
 base/modules/psi_z_mod.f90


New vector-buffered swaptran. Cosmetic fixes to swapdata.
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent 26906c1efc
commit 81158c0607
15 changed files with 880 additions and 1450 deletions
Show Stats Download Patch File Download Diff File

30
base/internals/psi_cswapdata.F90
Unescape Escape View File

@ -1045,7 +1045,6 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
@ -1054,6 +1053,8 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1067,8 +1068,6 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
@ -1095,13 +1094,13 @@ end subroutine psi_cswapdata_vect
!
!
! Subroutine: psi_cswapidx_vect
! Subroutine: psi_cswap_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routines will only choose the index list
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
@ -1134,8 +1133,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! 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_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1143,11 +1141,6 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -1155,6 +1148,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1213,13 +1207,13 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending.
!
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt
call y%gth(idx_pt,nesd,idx)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -1236,6 +1230,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_complex_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1243,8 +1238,6 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_complex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
@ -1277,6 +1270,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_complex_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1284,8 +1278,6 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_complex_swap_tag
if (proc_to_comm /= me)then
if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret)

416
base/internals/psi_cswaptran.F90
Unescape Escape View File

@ -185,12 +185,6 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -1049,10 +1043,10 @@ end subroutine psi_ctranidxv
subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptran_vect
use psb_c_base_vect_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
use psb_c_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1071,7 +1065,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
@ -1100,13 +1094,13 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1119,10 +1113,23 @@ end subroutine psi_cswaptran_vect
subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!
!
! Subroutine: psi_ctran_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidx_vect
use psi_mod, psb_protect_name => psi_ctran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1140,25 +1147,20 @@ subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: 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_mpik_), allocatable :: prcid(:)
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.
complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
@ -1185,306 +1187,196 @@ subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
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%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
call idx%sync()
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
if (debug) write(*,*) me,'do_send start'
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
snd_pt = 1
rcv_pt = 1
p2ptag = psb_complex_swap_tag
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_)
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 (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
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
if (debug) write(*,*) me,' Gather '
!
! Then gather for sending.
!
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 ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
nerv = idx%v(pnti+psb_n_elem_recv_)
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_
idx_pt = rcv_pt
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
!
call y%device_wait()
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (debug) write(*,*) me,' isend'
!
! Then send
!
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_complex_swap_tag
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_)
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_complex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,iret)
end if
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),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
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
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
pnti = pnti + nerv + nesd + 3
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
p2ptag = psb_complex_swap_tag
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_complex_swap_tag
if ((proc_to_comm /= me).and.(nesd>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
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nerv>0) then
call mpi_wait(y%comid(i,1),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
else if (proc_to_comm == me) then
if (nesd>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
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-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 (nerv>0) call psb_snd(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
else if (swap_recv) then
if (debug) write(*,*) me,' scatter'
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_rcv(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
end if
if (do_recv) then
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
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+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)
call y%sct(snd_pt,nesd,idx,beta)
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
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_ctranidx_vect
return
end subroutine psi_ctran_vidx_vect

30
base/internals/psi_dswapdata.F90
Unescape Escape View File

@ -1045,7 +1045,6 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
@ -1054,6 +1053,8 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1067,8 +1068,6 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
@ -1095,13 +1094,13 @@ end subroutine psi_dswapdata_vect
!
!
! Subroutine: psi_dswapidx_vect
! Subroutine: psi_dswap_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routines will only choose the index list
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
@ -1134,8 +1133,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! 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_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1143,11 +1141,6 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -1155,6 +1148,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1213,13 +1207,13 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending.
!
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt
call y%gth(idx_pt,nesd,idx)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -1236,6 +1230,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_double_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1243,8 +1238,6 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_double_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
@ -1277,6 +1270,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_double_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1284,8 +1278,6 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_double_swap_tag
if (proc_to_comm /= me)then
if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret)

416
base/internals/psi_dswaptran.F90
Unescape Escape View File

@ -185,12 +185,6 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -1049,10 +1043,10 @@ end subroutine psi_dtranidxv
subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptran_vect
use psb_d_base_vect_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
use psb_d_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1071,7 +1065,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
@ -1100,13 +1094,13 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1119,10 +1113,23 @@ end subroutine psi_dswaptran_vect
subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!
!
! Subroutine: psi_dtran_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidx_vect
use psi_mod, psb_protect_name => psi_dtran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1140,25 +1147,20 @@ subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: 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_mpik_), allocatable :: prcid(:)
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.
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
@ -1185,306 +1187,196 @@ subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
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%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
call idx%sync()
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
if (debug) write(*,*) me,'do_send start'
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
snd_pt = 1
rcv_pt = 1
p2ptag = psb_double_swap_tag
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_)
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 (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
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
if (debug) write(*,*) me,' Gather '
!
! Then gather for sending.
!
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 ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
nerv = idx%v(pnti+psb_n_elem_recv_)
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_
idx_pt = rcv_pt
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
!
call y%device_wait()
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (debug) write(*,*) me,' isend'
!
! Then send
!
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_double_swap_tag
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_)
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,iret)
end if
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),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
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
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
pnti = pnti + nerv + nesd + 3
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
p2ptag = psb_double_swap_tag
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_double_swap_tag
if ((proc_to_comm /= me).and.(nesd>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
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nerv>0) then
call mpi_wait(y%comid(i,1),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
else if (proc_to_comm == me) then
if (nesd>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
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-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 (nerv>0) call psb_snd(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
else if (swap_recv) then
if (debug) write(*,*) me,' scatter'
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_rcv(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
end if
if (do_recv) then
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
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+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)
call y%sct(snd_pt,nesd,idx,beta)
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
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_dtranidx_vect
return
end subroutine psi_dtran_vidx_vect

30
base/internals/psi_iswapdata.F90
Unescape Escape View File

@ -1045,7 +1045,6 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
@ -1054,6 +1053,8 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1067,8 +1068,6 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
@ -1095,13 +1094,13 @@ end subroutine psi_iswapdata_vect
!
!
! Subroutine: psi_iswapidx_vect
! Subroutine: psi_iswap_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routines will only choose the index list
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
@ -1134,8 +1133,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! 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_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1143,11 +1141,6 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -1155,6 +1148,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1213,13 +1207,13 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending.
!
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt
call y%gth(idx_pt,nesd,idx)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -1236,6 +1230,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_int_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1243,8 +1238,6 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_int_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
@ -1277,6 +1270,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_int_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1284,8 +1278,6 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_int_swap_tag
if (proc_to_comm /= me)then
if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret)

416
base/internals/psi_iswaptran.F90
Unescape Escape View File

@ -185,12 +185,6 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -1049,10 +1043,10 @@ end subroutine psi_itranidxv
subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptran_vect
use psb_i_base_vect_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1071,7 +1065,7 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
@ -1100,13 +1094,13 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1119,10 +1113,23 @@ end subroutine psi_iswaptran_vect
subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!
!
! Subroutine: psi_itran_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidx_vect
use psi_mod, psb_protect_name => psi_itran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1140,25 +1147,20 @@ subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: 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_mpik_), allocatable :: prcid(:)
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
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
@ -1185,306 +1187,196 @@ subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
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%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
call idx%sync()
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_ipk_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
if (debug) write(*,*) me,'do_send start'
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
snd_pt = 1
rcv_pt = 1
p2ptag = psb_int_swap_tag
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_)
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 (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
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
if (debug) write(*,*) me,' Gather '
!
! Then gather for sending.
!
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 ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
nerv = idx%v(pnti+psb_n_elem_recv_)
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_
idx_pt = rcv_pt
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
!
call y%device_wait()
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (debug) write(*,*) me,' isend'
!
! Then send
!
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_int_swap_tag
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_)
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
end if
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),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
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
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
pnti = pnti + nerv + nesd + 3
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
p2ptag = psb_int_swap_tag
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.(nesd>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
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nerv>0) then
call mpi_wait(y%comid(i,1),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
else if (proc_to_comm == me) then
if (nesd>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
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-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 (nerv>0) call psb_snd(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
else if (swap_recv) then
if (debug) write(*,*) me,' scatter'
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_rcv(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
end if
if (do_recv) then
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
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+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)
call y%sct(snd_pt,nesd,idx,beta)
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
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_itranidx_vect
return
end subroutine psi_itran_vidx_vect

30
base/internals/psi_sswapdata.F90
Unescape Escape View File

@ -1045,7 +1045,6 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
@ -1054,6 +1053,8 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1067,8 +1068,6 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
@ -1095,13 +1094,13 @@ end subroutine psi_sswapdata_vect
!
!
! Subroutine: psi_sswapidx_vect
! Subroutine: psi_sswap_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routines will only choose the index list
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
@ -1134,8 +1133,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! 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_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1143,11 +1141,6 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -1155,6 +1148,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1213,13 +1207,13 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending.
!
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt
call y%gth(idx_pt,nesd,idx)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -1236,6 +1230,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1243,8 +1238,6 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_real_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
@ -1277,6 +1270,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_real_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1284,8 +1278,6 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_real_swap_tag
if (proc_to_comm /= me)then
if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret)

416
base/internals/psi_sswaptran.F90
Unescape Escape View File

@ -185,12 +185,6 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -1049,10 +1043,10 @@ end subroutine psi_stranidxv
subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptran_vect
use psb_s_base_vect_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
use psb_s_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1071,7 +1065,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
@ -1100,13 +1094,13 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1119,10 +1113,23 @@ end subroutine psi_sswaptran_vect
subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!
!
! Subroutine: psi_stran_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidx_vect
use psi_mod, psb_protect_name => psi_stran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1140,25 +1147,20 @@ subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: 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_mpik_), allocatable :: prcid(:)
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.
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
@ -1185,306 +1187,196 @@ subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
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%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
call idx%sync()
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_spk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
if (debug) write(*,*) me,'do_send start'
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
snd_pt = 1
rcv_pt = 1
p2ptag = psb_real_swap_tag
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_)
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 (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
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
if (debug) write(*,*) me,' Gather '
!
! Then gather for sending.
!
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 ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
nerv = idx%v(pnti+psb_n_elem_recv_)
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_
idx_pt = rcv_pt
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
!
call y%device_wait()
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (debug) write(*,*) me,' isend'
!
! Then send
!
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_real_swap_tag
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_)
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_real_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,iret)
end if
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),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
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
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
pnti = pnti + nerv + nesd + 3
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
p2ptag = psb_real_swap_tag
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_real_swap_tag
if ((proc_to_comm /= me).and.(nesd>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
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nerv>0) then
call mpi_wait(y%comid(i,1),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
else if (proc_to_comm == me) then
if (nesd>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
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-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 (nerv>0) call psb_snd(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
else if (swap_recv) then
if (debug) write(*,*) me,' scatter'
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_rcv(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
end if
if (do_recv) then
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
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+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)
call y%sct(snd_pt,nesd,idx,beta)
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
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_stranidx_vect
return
end subroutine psi_stran_vidx_vect

30
base/internals/psi_zswapdata.F90
Unescape Escape View File

@ -1045,7 +1045,6 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
@ -1054,6 +1053,8 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1067,8 +1068,6 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
@ -1095,13 +1094,13 @@ end subroutine psi_zswapdata_vect
!
!
! Subroutine: psi_zswapidx_vect
! Subroutine: psi_zswap_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routines will only choose the index list
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
@ -1134,8 +1133,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! 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_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1143,11 +1141,6 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false., debug=.false.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
@ -1155,6 +1148,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@ -1213,13 +1207,13 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
! Then gather for sending.
!
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
idx_pt = snd_pt
call y%gth(idx_pt,nesd,idx)
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
@ -1236,6 +1230,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1243,8 +1238,6 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_dcomplex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
@ -1277,6 +1270,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
if (debug) write(*,*) me,' wait'
pnti = 1
p2ptag = psb_dcomplex_swap_tag
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
@ -1284,8 +1278,6 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
p2ptag = psb_dcomplex_swap_tag
if (proc_to_comm /= me)then
if (nesd>0) then
call mpi_wait(y%comid(i,1),p2pstat,iret)

416
base/internals/psi_zswaptran.F90
Unescape Escape View File

@ -185,12 +185,6 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, data_
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
@ -1049,10 +1043,10 @@ end subroutine psi_ztranidxv
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptran_vect
use psb_z_base_vect_mod
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
use psb_z_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
@ -1071,7 +1065,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
class(psb_i_base_vect_type), pointer :: d_vidx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
@ -1100,13 +1094,13 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -1119,10 +1113,23 @@ end subroutine psi_zswaptran_vect
subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!
!
! Subroutine: psi_ztran_vidx_vect
! Data exchange among processes.
!
! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods
! of vectors.
!
! The real workhorse: the outer routine will only choose the index list
! this one takes the index list and does the actual exchange.
!
!
!
subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidx_vect
use psi_mod, psb_protect_name => psi_ztran_vidx_vect
use psb_error_mod
use psb_desc_mod
use psb_penv_mod
@ -1140,25 +1147,20 @@ subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: 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_mpik_), allocatable :: prcid(:)
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.
complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
@ -1185,306 +1187,196 @@ subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
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
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%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
call idx%sync()
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_c_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
if (debug) write(*,*) me,'Internal buffer'
if (do_send) then
if (allocated(y%comid)) then
!
! Unfinished communication? Something is wrong....
!
info=psb_err_mpi_error_
ierr(1) = -2
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
if (debug) write(*,*) me,'do_send start'
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
snd_pt = 1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag
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_)
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 (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
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
if (debug) write(*,*) me,' Gather '
!
! Then gather for sending.
!
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 ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
nerv = idx%v(pnti+psb_n_elem_recv_)
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_
idx_pt = rcv_pt
call y%gth(idx_pt,nerv,idx)
pnti = pnti + nerv + nesd + 3
end do
!
! Then wait
!
call y%device_wait()
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (debug) write(*,*) me,' isend'
!
! Then send
!
pnti = 1
snd_pt = 1
rcv_pt = 1
p2ptag = psb_dcomplex_swap_tag
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_)
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_dcomplex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,iret)
end if
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),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
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
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
pnti = pnti + nerv + nesd + 3
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
p2ptag = psb_dcomplex_swap_tag
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_dcomplex_swap_tag
if ((proc_to_comm /= me).and.(nesd>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
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_)
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nerv>0) then
call mpi_wait(y%comid(i,1),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
else if (proc_to_comm == me) then
if (nesd>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
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-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 (nerv>0) call psb_snd(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
else if (swap_recv) then
if (debug) write(*,*) me,' scatter'
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_rcv(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
end if
if (do_recv) then
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_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
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+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)
call y%sct(snd_pt,nesd,idx,beta)
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
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_ztranidx_vect
return
end subroutine psi_ztran_vidx_vect

20
base/modules/psi_c_mod.f90
Unescape Escape View File

@ -81,7 +81,8 @@ module psi_c_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_cswapidxv
subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
@ -141,16 +142,17 @@ module psi_c_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ctranidxv
subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ctranidx_vect
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_vect
end interface
interface psi_ovrl_upd

20
base/modules/psi_d_mod.f90
Unescape Escape View File

@ -81,7 +81,8 @@ module psi_d_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv
subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
@ -141,16 +142,17 @@ module psi_d_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv
subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidx_vect
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_vect
end interface
interface psi_ovrl_upd

20
base/modules/psi_i_mod.f90
Unescape Escape View File

@ -241,7 +241,8 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxv
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)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
@ -301,16 +302,17 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxv
subroutine psi_itranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,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
end subroutine psi_itranidx_vect
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(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_vect
end interface
interface psi_ovrl_upd

20
base/modules/psi_s_mod.f90
Unescape Escape View File

@ -81,7 +81,8 @@ module psi_s_mod
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_sswapidxv
subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
@ -141,16 +142,17 @@ module psi_s_mod
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_stranidxv
subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_stranidx_vect
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_vect
end interface
interface psi_ovrl_upd

20
base/modules/psi_z_mod.f90
Unescape Escape View File

@ -81,7 +81,8 @@ module psi_z_mod
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_zswapidxv
subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
@ -141,16 +142,17 @@ module psi_z_mod
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxv
subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidx_vect
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_vect
end interface
interface psi_ovrl_upd

Write Preview
Loading…
Cancel
Save