diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index 59bfcb152..2e8f597e9 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -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) diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index f47a26c85..85a43f51a 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -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) diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index b5ea58db8..685019a17 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -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) diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index 1beebf5ef..ecc246492 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -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) diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index 890237cd8..542115be7 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -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) diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 25b13fe94..c3be481b8 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -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) diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index 72ea75816..0a5aecb58 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -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) diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 9fc907e7d..ffc153f2c 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -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) diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 73c2dbfca..caee14f9b 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -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) diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index b6b3fe3b5..2ae697d50 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -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)