From 225c2a71e02aa4a6914ec7af5f3cd76d25e8e842 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 20 Dec 2014 22:41:33 +0000 Subject: [PATCH] psblas3: base/internals/psi_cswapdata.F90 base/internals/psi_cswaptran.F90 base/internals/psi_dswapdata.F90 base/internals/psi_dswaptran.F90 base/internals/psi_iswapdata.F90 base/internals/psi_iswaptran.F90 base/internals/psi_sswapdata.F90 base/internals/psi_sswaptran.F90 base/internals/psi_zswapdata.F90 base/internals/psi_zswaptran.F90 base/modules/psi_i_mod.f90 New error handling. --- base/internals/psi_cswapdata.F90 | 56 ++--- base/internals/psi_cswaptran.F90 | 48 +--- base/internals/psi_dswapdata.F90 | 56 ++--- base/internals/psi_dswaptran.F90 | 48 +--- base/internals/psi_iswapdata.F90 | 411 ++++++++++++++++++++++++++++--- base/internals/psi_iswaptran.F90 | 48 +--- base/internals/psi_sswapdata.F90 | 56 ++--- base/internals/psi_sswaptran.F90 | 48 +--- base/internals/psi_zswapdata.F90 | 56 ++--- base/internals/psi_zswaptran.F90 | 48 +--- base/modules/psi_i_mod.f90 | 10 + 11 files changed, 500 insertions(+), 385 deletions(-) diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index 11eea421..b7c8d02f 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -147,13 +147,9 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapdatam subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -519,13 +515,9 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapidxm ! @@ -645,13 +637,9 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapdatav @@ -1005,13 +993,9 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapidxv subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) @@ -1082,13 +1066,9 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapdata_vect @@ -1444,13 +1424,9 @@ subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswapidx_vect @@ -1807,12 +1783,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswap_vidx_vect diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 9a54caea..0bb052db 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -152,13 +152,9 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswaptranm subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -526,13 +522,9 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ctranidxm ! ! @@ -655,13 +647,9 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswaptranv @@ -1031,13 +1019,9 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ctranidxv @@ -1107,13 +1091,9 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_cswaptran_vect @@ -1480,13 +1460,9 @@ subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ctranidx_vect diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 562d1481..1935f12a 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -147,13 +147,9 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapdatam subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -519,13 +515,9 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapidxm ! @@ -645,13 +637,9 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapdatav @@ -1005,13 +993,9 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapidxv subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) @@ -1082,13 +1066,9 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapdata_vect @@ -1444,13 +1424,9 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswapidx_vect @@ -1807,12 +1783,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswap_vidx_vect diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 682fcd7c..2dfc204b 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -152,13 +152,9 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswaptranm subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -526,13 +522,9 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dtranidxm ! ! @@ -655,13 +647,9 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswaptranv @@ -1031,13 +1019,9 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dtranidxv @@ -1107,13 +1091,9 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dswaptran_vect @@ -1480,13 +1460,9 @@ subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_dtranidx_vect diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index d4bd276b..fd7cd0c9 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -147,13 +147,9 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswapdatam subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -519,13 +515,9 @@ subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswapidxm ! @@ -645,13 +637,9 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswapdatav @@ -1005,13 +993,9 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswapidxv subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) @@ -1040,6 +1024,7 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) + class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name info=psb_success_ @@ -1068,25 +1053,22 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) +!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswapdata_vect @@ -1442,12 +1424,367 @@ subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return +end subroutine psi_iswapidx_vect + + +subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_iswap_vidx_vect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_i_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(in) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,nesd,idx,& + & sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_ipk_integer,rcvbuf,rvsz,& + & brvidx,psb_mpi_ipk_integer,icomm,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%sct(idx_pt,nerv,idx,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) return -end subroutine psi_iswapidx_vect + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iswap_vidx_vect diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index 60985ed4..9b50ae7c 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -152,13 +152,9 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswaptranm subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -526,13 +522,9 @@ subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_itranidxm ! ! @@ -655,13 +647,9 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswaptranv @@ -1031,13 +1019,9 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_itranidxv @@ -1107,13 +1091,9 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_iswaptran_vect @@ -1480,13 +1460,9 @@ subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_itranidx_vect diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index 75fc4024..9f8d5000 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -147,13 +147,9 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapdatam subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -519,13 +515,9 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapidxm ! @@ -645,13 +637,9 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapdatav @@ -1005,13 +993,9 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapidxv subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) @@ -1082,13 +1066,9 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapdata_vect @@ -1444,13 +1424,9 @@ subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswapidx_vect @@ -1807,12 +1783,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswap_vidx_vect diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index 5fd21243..26d391a5 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -152,13 +152,9 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswaptranm subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -526,13 +522,9 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_stranidxm ! ! @@ -655,13 +647,9 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswaptranv @@ -1031,13 +1019,9 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_stranidxv @@ -1107,13 +1091,9 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_sswaptran_vect @@ -1480,13 +1460,9 @@ subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_stranidx_vect diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 379b02fd..1234dbe4 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -147,13 +147,9 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapdatam subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -519,13 +515,9 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapidxm ! @@ -645,13 +637,9 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapdatav @@ -1005,13 +993,9 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapidxv subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) @@ -1082,13 +1066,9 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapdata_vect @@ -1444,13 +1424,9 @@ subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswapidx_vect @@ -1807,12 +1783,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrc call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswap_vidx_vect diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 2286761c..5004aedd 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -152,13 +152,9 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswaptranm subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -526,13 +522,9 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,wo call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ztranidxm ! ! @@ -655,13 +647,9 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswaptranv @@ -1031,13 +1019,9 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ztranidxv @@ -1107,13 +1091,9 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_zswaptran_vect @@ -1480,13 +1460,9 @@ subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) +9999 call psb_error_handler(ictxt,err_act) + return - end if - return end subroutine psi_ztranidx_vect diff --git a/base/modules/psi_i_mod.f90 b/base/modules/psi_i_mod.f90 index 6c836f24..50713627 100644 --- a/base/modules/psi_i_mod.f90 +++ b/base/modules/psi_i_mod.f90 @@ -251,6 +251,16 @@ module psi_i_mod integer(psb_ipk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_iswapidx_vect + subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + import :: psb_desc_type, psb_ipk_, psb_i_base_vect_type + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(in) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_iswap_vidx_vect end interface