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

psblas3:

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

New error handling.
psblas3-accel
Salvatore Filippone 10 years ago
parent 53732e40ea
commit 225c2a71e0
11 changed files with 500 additions and 385 deletions
Show Stats Download Patch File Download Diff File

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

Write Preview
Loading…
Cancel
Save