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

Try waitall for data exchange.

Browse Source
waitall
Salvatore Filippone 8 years ago
parent ce33f6b6ed
commit 26e7358d24
10 changed files with 385 additions and 625 deletions
Show Stats Download Patch File Download Diff File

99
base/comm/internals/psi_cswapdata.F90
Unescape Escape View File

@ -666,6 +666,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -741,7 +742,8 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -847,6 +849,8 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -878,28 +882,6 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_complex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -909,14 +891,24 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, &
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1115,7 +1107,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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1168,6 +1160,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
@ -1183,6 +1176,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1226,6 +1221,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1251,37 +1248,30 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_complex_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nesd>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
if (nerv>0) then
call mpi_wait(y%comid(i,2),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
else if (proc_to_comm == me) then
if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1289,21 +1279,6 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,idx,beta)

103
base/comm/internals/psi_cswaptran.F90
Unescape Escape View File

@ -681,6 +681,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,&
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -756,7 +757,8 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,&
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -865,7 +867,9 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,&
p2ptag = psb_complex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -902,39 +906,28 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_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
end if
else if (proc_to_comm == me) then
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)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1134,7 +1127,7 @@ subroutine psi_ctran_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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1188,6 +1181,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
p2ptag = psb_complex_swap_tag
@ -1204,6 +1198,8 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1251,6 +1247,8 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1276,37 +1274,30 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_complex_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
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
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 (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1314,20 +1305,6 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
end if
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
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)

99
base/comm/internals/psi_dswapdata.F90
Unescape Escape View File

@ -666,6 +666,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -741,7 +742,8 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -847,6 +849,8 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -878,28 +882,6 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_double_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -909,14 +891,24 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1115,7 +1107,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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1168,6 +1160,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
@ -1183,6 +1176,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1226,6 +1221,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1251,37 +1248,30 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_double_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nesd>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
if (nerv>0) then
call mpi_wait(y%comid(i,2),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
else if (proc_to_comm == me) then
if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1289,21 +1279,6 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,idx,beta)

103
base/comm/internals/psi_dswaptran.F90
Unescape Escape View File

@ -681,6 +681,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,&
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -756,7 +757,8 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,&
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -865,7 +867,9 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,&
p2ptag = psb_double_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -902,39 +906,28 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_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
end if
else if (proc_to_comm == me) then
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)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1134,7 +1127,7 @@ subroutine psi_dtran_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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1188,6 +1181,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
p2ptag = psb_double_swap_tag
@ -1204,6 +1198,8 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1251,6 +1247,8 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1276,37 +1274,30 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_double_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
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
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 (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1314,20 +1305,6 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
end if
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
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)

99
base/comm/internals/psi_iswapdata.F90
Unescape Escape View File

@ -666,6 +666,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -741,7 +742,8 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -847,6 +849,8 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -878,28 +882,6 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -909,14 +891,24 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, &
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1115,7 +1107,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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1168,6 +1160,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
@ -1183,6 +1176,8 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1226,6 +1221,8 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1251,37 +1248,30 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_int_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nesd>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
if (nerv>0) then
call mpi_wait(y%comid(i,2),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
else if (proc_to_comm == me) then
if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1289,21 +1279,6 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,idx,beta)

103
base/comm/internals/psi_iswaptran.F90
Unescape Escape View File

@ -681,6 +681,7 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,&
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -756,7 +757,8 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,&
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -865,7 +867,9 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,&
p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -902,39 +906,28 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((proc_to_comm /= me).and.(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
end if
else if (proc_to_comm == me) then
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)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1134,7 +1127,7 @@ subroutine psi_itran_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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1188,6 +1181,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
p2ptag = psb_int_swap_tag
@ -1204,6 +1198,8 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1251,6 +1247,8 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1276,37 +1274,30 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_int_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
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
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 (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1314,20 +1305,6 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
end if
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
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)

99
base/comm/internals/psi_sswapdata.F90
Unescape Escape View File

@ -666,6 +666,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -741,7 +742,8 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -847,6 +849,8 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -878,28 +882,6 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_real_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -909,14 +891,24 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, &
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1115,7 +1107,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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1168,6 +1160,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
@ -1183,6 +1176,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1226,6 +1221,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1251,37 +1248,30 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_real_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nesd>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
if (nerv>0) then
call mpi_wait(y%comid(i,2),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
else if (proc_to_comm == me) then
if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1289,21 +1279,6 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,idx,beta)

103
base/comm/internals/psi_sswaptran.F90
Unescape Escape View File

@ -681,6 +681,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,&
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -756,7 +757,8 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,&
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -865,7 +867,9 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,&
p2ptag = psb_real_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -902,39 +906,28 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_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
end if
else if (proc_to_comm == me) then
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)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1134,7 +1127,7 @@ subroutine psi_stran_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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1188,6 +1181,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
p2ptag = psb_real_swap_tag
@ -1204,6 +1198,8 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1251,6 +1247,8 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_spk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1276,37 +1274,30 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_real_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
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
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 (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1314,20 +1305,6 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
end if
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
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)

99
base/comm/internals/psi_zswapdata.F90
Unescape Escape View File

@ -666,6 +666,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -741,7 +742,8 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -847,6 +849,8 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -878,28 +882,6 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_dcomplex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -909,14 +891,24 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, &
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1115,7 +1107,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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1168,6 +1160,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
do i=1, totxch
@ -1183,6 +1176,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1226,6 +1221,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1251,37 +1248,30 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_dcomplex_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (proc_to_comm /= me)then
if (nesd>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
if (nerv>0) then
call mpi_wait(y%comid(i,2),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
else if (proc_to_comm == me) then
if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1289,21 +1279,6 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
end if
y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(rcv_pt:rcv_pt+nerv-1)
call y%sct(rcv_pt,nerv,idx,beta)

103
base/comm/internals/psi_zswaptran.F90
Unescape Escape View File

@ -681,6 +681,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,&
& 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 :: statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -756,7 +757,8 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,&
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
allocate(rvhd(totxch),prcid(totxch),&
& statsarray(totxch,mpi_status_size),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
@ -865,7 +867,9 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,&
p2ptag = psb_dcomplex_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag, icomm,rvhd(i),iret)
else
rvhd(i) = mpi_request_null
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -902,39 +906,28 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,&
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_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
end if
else if (proc_to_comm == me) then
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)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
call mpi_waitall(totxch,rvhd,statsarray,iret)
if (iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_send) then
@ -1134,7 +1127,7 @@ subroutine psi_ztran_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 :: prcid(:)
integer(psb_mpik_), allocatable :: prcid(:), statsarray(:,:)
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
@ -1188,6 +1181,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call y%new_comid(totxch,info)
y%comid = mpi_request_null
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
! First I post all the non blocking receives
pnti = 1
p2ptag = psb_dcomplex_swap_tag
@ -1204,6 +1198,8 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
else
y%comid(i,2) = mpi_request_null
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1251,6 +1247,8 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_c_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
else
y%comid(i,1) = mpi_request_null
end if
if(iret /= mpi_success) then
@ -1276,37 +1274,30 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
goto 9999
end if
call psb_realloc(totxch,prcid,info)
if (info == 0) call psb_realloc(totxch,mpi_status_size,statsarray,info)
if (debug) write(*,*) me,' wait'
call mpi_waitall(totxch,y%comid(:,1),statsarray,iret)
if (iret == mpi_success) call mpi_waitall(totxch,y%comid(:,2),statsarray,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
if (debug) write(*,*) me,' scatter'
pnti = 1
p2ptag = psb_dcomplex_swap_tag
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
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
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 (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
@ -1314,20 +1305,6 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
end if
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
if (debug) write(*,*) me,' scatter'
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx%v(pnti+psb_proc_id_)
nerv = idx%v(pnti+psb_n_elem_recv_)
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
if (debug) write(0,*)me,' Received from: ',prcid(i),&
& y%combuf(snd_pt:snd_pt+nesd-1)

Write Preview
Loading…
Cancel
Save