diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index 4e0b8e78..add77f16 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -140,7 +140,6 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 @@ -197,6 +196,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -230,7 +230,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -249,7 +248,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else @@ -310,7 +308,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_sync) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -337,7 +334,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) end if - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -348,7 +344,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -372,7 +367,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! Then I post all the blocking sends if (usersend) call mpi_barrier(icomm,iret) - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -407,7 +401,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end do - pnti = 1 do i=1, totxch proc_to_comm = idx(pnti+psb_proc_id_) @@ -438,7 +431,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -448,7 +440,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ictxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -457,7 +448,6 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -474,11 +464,8 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if - - if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -604,7 +591,8 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -618,9 +606,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%get_mpic() - - if(present(data)) then + if (present(data)) then data_ = data else data_ = psb_comm_halo_ @@ -644,7 +630,6 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswapdatav - ! ! ! Subroutine: psi_cswapdataidxv @@ -700,6 +685,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -708,8 +694,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -911,7 +896,6 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & 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 @@ -1051,9 +1035,8 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1156,8 +1139,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -1170,18 +1152,21 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1324,16 +1309,19 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call y%sct(rcv_pt,nerv,idx,beta) pnti = pnti + nerv + nesd + 3 end do - + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1355,10 +1343,9 @@ end subroutine psi_cswap_vidx_vect ! Subroutine: psi_cswapdata_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. +! Takes care of Y an encaspulated vector. ! ! -! subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_cswapdata_multivect @@ -1391,9 +1378,8 @@ subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1436,7 +1422,7 @@ end subroutine psi_cswapdata_multivect ! Subroutine: psi_cswap_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods ! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list @@ -1464,8 +1450,8 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv @@ -1506,22 +1492,26 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & totrcv_ = totrcv * n totsnd_ = totsnd * n + call idx%sync() if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1561,7 +1551,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() @@ -1649,7 +1639,6 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do if (debug) write(*,*) me,' scatter' @@ -1669,16 +1658,19 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 end do - - ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index f0dc8946..2b6f8c25 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -157,7 +157,8 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_cswaptranm -subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxm use psb_error_mod @@ -209,11 +210,11 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo goto 9999 endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv @@ -242,10 +243,8 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -265,7 +264,6 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo end if end if - totrcv_ = max(totrcv_,1) totsnd_ = max(totsnd_,1) if((totrcv_+totsnd_) < size(work)) then @@ -657,9 +655,8 @@ end subroutine psi_cswaptranv ! ! ! - - -subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxv use psb_error_mod @@ -687,12 +684,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& -!!$ & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -743,7 +734,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -857,7 +847,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -917,7 +906,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -962,7 +950,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -979,12 +966,10 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do end if - if (do_recv) then pnti = 1 @@ -1004,7 +989,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end if - if (swap_mpi) then deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& & stat=info) @@ -1028,10 +1012,6 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_ctranidxv - - -! -! ! ! ! Subroutine: psi_cswaptran_vect @@ -1131,6 +1111,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_ctran_vidx_vect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_c_base_vect_mod @@ -1191,18 +1172,21 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1248,7 +1232,6 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1351,16 +1334,19 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%sct(snd_pt,nesd,idx,beta) pnti = pnti + nerv + nesd + 3 end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null - ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1386,7 +1372,7 @@ end subroutine psi_ctran_vidx_vect ! Subroutine: psi_cswaptran_vect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. +! Takes care of Y an encaspulated vector. ! ! subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) @@ -1461,14 +1447,13 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswaptran_multivect - ! ! -! Subroutine: psi_ctran_vidx_vect +! Subroutine: psi_ctran_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list ! this one takes the index list and does the actual exchange. @@ -1480,9 +1465,10 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_ctran_vidx_multivect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod - use psb_c_base_vect_mod + use psb_c_base_multivect_mod #ifdef MPI_MOD use mpi #endif @@ -1542,17 +1528,20 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1593,12 +1582,11 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1686,8 +1674,6 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do if (debug) write(*,*) me,' scatter' - - pnti = 1 snd_pt = totrcv_+1 rcv_pt = 1 @@ -1707,13 +1693,18 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index 21df89d3..46cdf0d7 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -140,7 +140,6 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 @@ -197,6 +196,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -230,7 +230,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -249,7 +248,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else @@ -310,7 +308,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_sync) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -337,7 +334,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) end if - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -348,7 +344,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -372,7 +367,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! Then I post all the blocking sends if (usersend) call mpi_barrier(icomm,iret) - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -407,7 +401,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end do - pnti = 1 do i=1, totxch proc_to_comm = idx(pnti+psb_proc_id_) @@ -438,7 +431,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -448,7 +440,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ictxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -457,7 +448,6 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -474,11 +464,8 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if - - if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -604,7 +591,8 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -618,9 +606,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%get_mpic() - - if(present(data)) then + if (present(data)) then data_ = data else data_ = psb_comm_halo_ @@ -644,7 +630,6 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswapdatav - ! ! ! Subroutine: psi_dswapdataidxv @@ -700,6 +685,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -708,8 +694,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -911,7 +896,6 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & 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 @@ -1051,9 +1035,8 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1156,8 +1139,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -1170,18 +1152,21 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1324,16 +1309,19 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call y%sct(rcv_pt,nerv,idx,beta) pnti = pnti + nerv + nesd + 3 end do - + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1355,10 +1343,9 @@ end subroutine psi_dswap_vidx_vect ! Subroutine: psi_dswapdata_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. +! Takes care of Y an encaspulated vector. ! ! -! subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_dswapdata_multivect @@ -1391,9 +1378,8 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1436,7 +1422,7 @@ end subroutine psi_dswapdata_multivect ! Subroutine: psi_dswap_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods ! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list @@ -1464,8 +1450,8 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv @@ -1506,22 +1492,26 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & totrcv_ = totrcv * n totsnd_ = totsnd * n + call idx%sync() if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1561,7 +1551,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() @@ -1649,7 +1639,6 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do if (debug) write(*,*) me,' scatter' @@ -1669,16 +1658,19 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 end do - - ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index e497b0f4..a94df153 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -157,7 +157,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_dswaptranm -subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxm use psb_error_mod @@ -209,11 +210,11 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo goto 9999 endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv @@ -242,10 +243,8 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -265,7 +264,6 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo end if end if - totrcv_ = max(totrcv_,1) totsnd_ = max(totsnd_,1) if((totrcv_+totsnd_) < size(work)) then @@ -657,9 +655,8 @@ end subroutine psi_dswaptranv ! ! ! - - -subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxv use psb_error_mod @@ -687,12 +684,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& -!!$ & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -743,7 +734,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -857,7 +847,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -917,7 +906,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -962,7 +950,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -979,12 +966,10 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do end if - if (do_recv) then pnti = 1 @@ -1004,7 +989,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end if - if (swap_mpi) then deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& & stat=info) @@ -1028,10 +1012,6 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_dtranidxv - - -! -! ! ! ! Subroutine: psi_dswaptran_vect @@ -1131,6 +1111,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_dtran_vidx_vect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_d_base_vect_mod @@ -1191,18 +1172,21 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1248,7 +1232,6 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1351,16 +1334,19 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%sct(snd_pt,nesd,idx,beta) pnti = pnti + nerv + nesd + 3 end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null - ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1386,7 +1372,7 @@ end subroutine psi_dtran_vidx_vect ! Subroutine: psi_dswaptran_vect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. +! Takes care of Y an encaspulated vector. ! ! subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) @@ -1461,14 +1447,13 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswaptran_multivect - ! ! -! Subroutine: psi_dtran_vidx_vect +! Subroutine: psi_dtran_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list ! this one takes the index list and does the actual exchange. @@ -1480,9 +1465,10 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_dtran_vidx_multivect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod - use psb_d_base_vect_mod + use psb_d_base_multivect_mod #ifdef MPI_MOD use mpi #endif @@ -1542,17 +1528,20 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1593,12 +1582,11 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1686,8 +1674,6 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do if (debug) write(*,*) me,' scatter' - - pnti = 1 snd_pt = totrcv_+1 rcv_pt = 1 @@ -1707,13 +1693,18 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index 28baf259..94b6466d 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -140,7 +140,6 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 @@ -197,6 +196,7 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -230,7 +230,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -249,7 +248,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else @@ -310,7 +308,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_sync) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -337,7 +334,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) end if - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -348,7 +344,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -372,7 +367,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! Then I post all the blocking sends if (usersend) call mpi_barrier(icomm,iret) - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -407,7 +401,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end do - pnti = 1 do i=1, totxch proc_to_comm = idx(pnti+psb_proc_id_) @@ -438,7 +431,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -448,7 +440,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ictxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -457,7 +448,6 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -474,11 +464,8 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if - - if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -604,7 +591,8 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -618,9 +606,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%get_mpic() - - if(present(data)) then + if (present(data)) then data_ = data else data_ = psb_comm_halo_ @@ -644,7 +630,6 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswapdatav - ! ! ! Subroutine: psi_iswapdataidxv @@ -700,6 +685,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -708,8 +694,7 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -911,7 +896,6 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & 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 @@ -1051,9 +1035,8 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1156,8 +1139,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -1170,18 +1152,21 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1324,16 +1309,19 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call y%sct(rcv_pt,nerv,idx,beta) pnti = pnti + nerv + nesd + 3 end do - + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1355,10 +1343,9 @@ end subroutine psi_iswap_vidx_vect ! Subroutine: psi_iswapdata_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. +! Takes care of Y an encaspulated vector. ! ! -! subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_iswapdata_multivect @@ -1391,9 +1378,8 @@ subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1436,7 +1422,7 @@ end subroutine psi_iswapdata_multivect ! Subroutine: psi_iswap_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods ! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list @@ -1464,8 +1450,8 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv @@ -1506,22 +1492,26 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & totrcv_ = totrcv * n totsnd_ = totsnd * n + call idx%sync() if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1561,7 +1551,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() @@ -1649,7 +1639,6 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do if (debug) write(*,*) me,' scatter' @@ -1669,16 +1658,19 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 end do - - ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 34bb47cf..5f126988 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -157,7 +157,8 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_iswaptranm -subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itranidxm use psb_error_mod @@ -209,11 +210,11 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo goto 9999 endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv @@ -242,10 +243,8 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -265,7 +264,6 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo end if end if - totrcv_ = max(totrcv_,1) totsnd_ = max(totsnd_,1) if((totrcv_+totsnd_) < size(work)) then @@ -657,9 +655,8 @@ end subroutine psi_iswaptranv ! ! ! - - -subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itranidxv use psb_error_mod @@ -687,12 +684,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& -!!$ & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -743,7 +734,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -857,7 +847,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -917,7 +906,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -962,7 +950,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -979,12 +966,10 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do end if - if (do_recv) then pnti = 1 @@ -1004,7 +989,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end if - if (swap_mpi) then deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& & stat=info) @@ -1028,10 +1012,6 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_itranidxv - - -! -! ! ! ! Subroutine: psi_iswaptran_vect @@ -1131,6 +1111,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_itran_vidx_vect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_i_base_vect_mod @@ -1191,18 +1172,21 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1248,7 +1232,6 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1351,16 +1334,19 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%sct(snd_pt,nesd,idx,beta) pnti = pnti + nerv + nesd + 3 end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null - ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1386,7 +1372,7 @@ end subroutine psi_itran_vidx_vect ! Subroutine: psi_iswaptran_vect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. +! Takes care of Y an encaspulated vector. ! ! subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) @@ -1461,14 +1447,13 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswaptran_multivect - ! ! -! Subroutine: psi_itran_vidx_vect +! Subroutine: psi_itran_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list ! this one takes the index list and does the actual exchange. @@ -1480,9 +1465,10 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_itran_vidx_multivect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod - use psb_i_base_vect_mod + use psb_i_base_multivect_mod #ifdef MPI_MOD use mpi #endif @@ -1542,17 +1528,20 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1593,12 +1582,11 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1686,8 +1674,6 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do if (debug) write(*,*) me,' scatter' - - pnti = 1 snd_pt = totrcv_+1 rcv_pt = 1 @@ -1707,13 +1693,18 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index 42dc9d09..9a1f7b25 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -140,7 +140,6 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 @@ -197,6 +196,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -230,7 +230,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -249,7 +248,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else @@ -310,7 +308,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_sync) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -337,7 +334,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) end if - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -348,7 +344,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -372,7 +367,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! Then I post all the blocking sends if (usersend) call mpi_barrier(icomm,iret) - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -407,7 +401,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end do - pnti = 1 do i=1, totxch proc_to_comm = idx(pnti+psb_proc_id_) @@ -438,7 +431,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -448,7 +440,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ictxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -457,7 +448,6 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -474,11 +464,8 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if - - if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -604,7 +591,8 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -618,9 +606,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%get_mpic() - - if(present(data)) then + if (present(data)) then data_ = data else data_ = psb_comm_halo_ @@ -644,7 +630,6 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswapdatav - ! ! ! Subroutine: psi_sswapdataidxv @@ -700,6 +685,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -708,8 +694,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -911,7 +896,6 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & 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 @@ -1051,9 +1035,8 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1156,8 +1139,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -1170,18 +1152,21 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1324,16 +1309,19 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call y%sct(rcv_pt,nerv,idx,beta) pnti = pnti + nerv + nesd + 3 end do - + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1355,10 +1343,9 @@ end subroutine psi_sswap_vidx_vect ! Subroutine: psi_sswapdata_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. +! Takes care of Y an encaspulated vector. ! ! -! subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_sswapdata_multivect @@ -1391,9 +1378,8 @@ subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1436,7 +1422,7 @@ end subroutine psi_sswapdata_multivect ! Subroutine: psi_sswap_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods ! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list @@ -1464,8 +1450,8 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv @@ -1506,22 +1492,26 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & totrcv_ = totrcv * n totsnd_ = totsnd * n + call idx%sync() if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1561,7 +1551,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() @@ -1649,7 +1639,6 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do if (debug) write(*,*) me,' scatter' @@ -1669,16 +1658,19 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 end do - - ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 49587fe5..e99692fc 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -157,7 +157,8 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_sswaptranm -subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxm use psb_error_mod @@ -209,11 +210,11 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo goto 9999 endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv @@ -242,10 +243,8 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -265,7 +264,6 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo end if end if - totrcv_ = max(totrcv_,1) totsnd_ = max(totsnd_,1) if((totrcv_+totsnd_) < size(work)) then @@ -657,9 +655,8 @@ end subroutine psi_sswaptranv ! ! ! - - -subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxv use psb_error_mod @@ -687,12 +684,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& -!!$ & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -743,7 +734,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -857,7 +847,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -917,7 +906,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -962,7 +950,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -979,12 +966,10 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do end if - if (do_recv) then pnti = 1 @@ -1004,7 +989,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end if - if (swap_mpi) then deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& & stat=info) @@ -1028,10 +1012,6 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_stranidxv - - -! -! ! ! ! Subroutine: psi_sswaptran_vect @@ -1131,6 +1111,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_stran_vidx_vect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_s_base_vect_mod @@ -1191,18 +1172,21 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1248,7 +1232,6 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1351,16 +1334,19 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%sct(snd_pt,nesd,idx,beta) pnti = pnti + nerv + nesd + 3 end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null - ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1386,7 +1372,7 @@ end subroutine psi_stran_vidx_vect ! Subroutine: psi_sswaptran_vect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. +! Takes care of Y an encaspulated vector. ! ! subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) @@ -1461,14 +1447,13 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswaptran_multivect - ! ! -! Subroutine: psi_stran_vidx_vect +! Subroutine: psi_stran_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list ! this one takes the index list and does the actual exchange. @@ -1480,9 +1465,10 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_stran_vidx_multivect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod - use psb_s_base_vect_mod + use psb_s_base_multivect_mod #ifdef MPI_MOD use mpi #endif @@ -1542,17 +1528,20 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1593,12 +1582,11 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1686,8 +1674,6 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do if (debug) write(*,*) me,' scatter' - - pnti = 1 snd_pt = totrcv_+1 rcv_pt = 1 @@ -1707,13 +1693,18 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 4fa5e19a..260f39d1 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -140,7 +140,6 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 @@ -197,6 +196,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -230,7 +230,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -249,7 +248,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do else @@ -310,7 +308,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_sync) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -337,7 +334,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) end if - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -348,7 +344,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -372,7 +367,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & ! Then I post all the blocking sends if (usersend) call mpi_barrier(icomm,iret) - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -407,7 +401,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end do - pnti = 1 do i=1, totxch proc_to_comm = idx(pnti+psb_proc_id_) @@ -438,7 +431,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_send) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -448,7 +440,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ictxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -457,7 +448,6 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & else if (swap_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -474,11 +464,8 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & end if - - if (do_recv) then - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -604,7 +591,8 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -618,9 +606,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - icomm = desc_a%get_mpic() - - if(present(data)) then + if (present(data)) then data_ = data else data_ = psb_comm_halo_ @@ -644,7 +630,6 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswapdatav - ! ! ! Subroutine: psi_zswapdataidxv @@ -700,6 +685,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionsave(err_act) ictxt = iictxt icomm = iicomm + call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -708,8 +694,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -911,7 +896,6 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & 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 @@ -1051,9 +1035,8 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1156,8 +1139,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & endif n=1 - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 @@ -1170,18 +1152,21 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1324,16 +1309,19 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call y%sct(rcv_pt,nerv,idx,beta) pnti = pnti + nerv + nesd + 3 end do - + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1355,10 +1343,9 @@ end subroutine psi_zswap_vidx_vect ! Subroutine: psi_zswapdata_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. +! Takes care of Y an encaspulated vector. ! ! -! subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_zswapdata_multivect @@ -1391,9 +1378,8 @@ subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ictxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) if (np == -1) then info=psb_err_context_error_ @@ -1436,7 +1422,7 @@ end subroutine psi_zswapdata_multivect ! Subroutine: psi_zswap_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods ! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list @@ -1464,8 +1450,8 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv @@ -1506,22 +1492,26 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & totrcv_ = totrcv * n totsnd_ = totsnd * n + call idx%sync() if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1561,7 +1551,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() @@ -1649,7 +1639,6 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 - end do if (debug) write(*,*) me,' scatter' @@ -1669,16 +1658,19 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 end do - - ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index c4478e41..cbb68c2b 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -157,7 +157,8 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) return end subroutine psi_zswaptranm -subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxm use psb_error_mod @@ -209,11 +210,11 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo goto 9999 endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv @@ -242,10 +243,8 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -265,7 +264,6 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo end if end if - totrcv_ = max(totrcv_,1) totsnd_ = max(totsnd_,1) if((totrcv_+totsnd_) < size(work)) then @@ -657,9 +655,8 @@ end subroutine psi_zswaptranv ! ! ! - - -subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) +subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxv use psb_error_mod @@ -687,12 +684,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n -!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& -!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& -!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& -!!$ & snd_pt, rcv_pt, pnti, data_, n -!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,& -!!$ & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -743,7 +734,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work ! prepare info for communications - pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -857,7 +847,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -917,7 +906,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do @@ -962,7 +950,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do else if (swap_recv) then @@ -979,12 +966,10 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd pnti = pnti + nerv + nesd + 3 - end do end if - if (do_recv) then pnti = 1 @@ -1004,7 +989,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end if - if (swap_mpi) then deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& & stat=info) @@ -1028,10 +1012,6 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_ztranidxv - - -! -! ! ! ! Subroutine: psi_zswaptran_vect @@ -1131,6 +1111,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_ztran_vidx_vect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_z_base_vect_mod @@ -1191,18 +1172,21 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1248,7 +1232,6 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1351,16 +1334,19 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call y%sct(snd_pt,nesd,idx,beta) pnti = pnti + nerv + nesd + 3 end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null - ! - ! Then wait + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1386,7 +1372,7 @@ end subroutine psi_ztran_vidx_vect ! Subroutine: psi_zswaptran_vect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. +! Takes care of Y an encaspulated vector. ! ! subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) @@ -1461,14 +1447,13 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswaptran_multivect - ! ! -! Subroutine: psi_ztran_vidx_vect +! Subroutine: psi_ztran_vidx_multivect ! Data exchange among processes. ! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. ! ! The real workhorse: the outer routine will only choose the index list ! this one takes the index list and does the actual exchange. @@ -1480,9 +1465,10 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& use psi_mod, psb_protect_name => psi_ztran_vidx_multivect use psb_error_mod + use psb_realloc_mod use psb_desc_mod use psb_penv_mod - use psb_z_base_vect_mod + use psb_z_base_multivect_mod #ifdef MPI_MOD use mpi #endif @@ -1542,17 +1528,20 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (debug) write(*,*) me,'Internal buffer' if (do_send) then if (allocated(y%comid)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) - goto 9999 + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) call y%new_comid(totxch,info) + y%comid = mpi_request_null call psb_realloc(totxch,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -1593,12 +1582,11 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do ! - ! Then wait + ! Then wait for device ! call y%device_wait() if (debug) write(*,*) me,' isend' - ! ! Then send ! @@ -1686,8 +1674,6 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end do if (debug) write(*,*) me,' scatter' - - pnti = 1 snd_pt = totrcv_+1 rcv_pt = 1 @@ -1707,13 +1693,18 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! - ! Then wait + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device ! if (debug) write(*,*) me,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) +!!$ if (debug) write(*,*) me,' free buffer' +!!$ call y%free_buffer(info) +!!$ if (info == 0) call y%free_comid(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999